diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,3 +1,15 @@
+### 0.6.0 (Sep 03, 2021)
+  * IF and CASE block constructs are now parsed as blocks at parsing instead of
+    as a post-parse transformation (no intermediate statement representation)
+    #154
+  * add ASSOCIATE block construct (Fortran 2003 parser only) #165
+  * `CommonGroup` AST nodes now store `Declarator`s instead of `Expression`s
+    #173
+    * various bug fixes related to their typing as a result
+  * CI now building on Windows, and save Linux & Windows executables for each
+    build
+  * various bugfixes (#34, #155)
+
 ### 0.5.0 (Jun 30, 2021)
   * Introduce a second-stage type representation including kind info alongside
     types, and resolving some types to semantic type with preset kinds (e.g.
diff --git a/fortran-src.cabal b/fortran-src.cabal
--- a/fortran-src.cabal
+++ b/fortran-src.cabal
@@ -5,7 +5,7 @@
 -- see: https://github.com/sol/hpack
 
 name:           fortran-src
-version:        0.5.0
+version:        0.6.0
 synopsis:       Parsers and analyses for Fortran standards 66, 77, 90 and 95.
 description:    Provides lexing, parsing, and basic analyses of Fortran code covering standards: FORTRAN 66, FORTRAN 77, Fortran 90, and Fortran 95 and some legacy extensions. Includes data flow and basic block analysis, a renamer, and type analysis. For example usage, see the 'camfort' project, which uses fortran-src as its front end.
 category:       Language
diff --git a/src/Language/Fortran/AST.hs b/src/Language/Fortran/AST.hs
--- a/src/Language/Fortran/AST.hs
+++ b/src/Language/Fortran/AST.hs
@@ -91,7 +91,6 @@
   , A0
   , Annotated(..)
   , Labeled(..)
-  , Conditioned(..)
   , Named(..)
 
   -- * Helpers
@@ -185,8 +184,9 @@
 -- guarantees that it will be Nothing. For CHARACTER types, both maybe or may
 -- not be present.
 data Selector a =
---                   Maybe length         | Maybe kind
-  Selector a SrcSpan (Maybe (Expression a)) (Maybe (Expression a))
+  Selector a SrcSpan
+    (Maybe (Expression a)) -- ^ length (if present)
+    (Maybe (Expression a)) -- ^ kind (if present)
   deriving (Eq, Show, Data, Typeable, Generic, Functor)
 
 type Kind = Int
@@ -303,52 +303,61 @@
 
 data Block a =
     BlStatement a SrcSpan
-                (Maybe (Expression a))       -- Label
-                (Statement a)                -- Statement
+                (Maybe (Expression a))       -- ^ Label
+                (Statement a)                -- ^ Statement
 
   | BlForall    a SrcSpan
-                (Maybe (Expression a))       -- Label
-                (Maybe String)               -- Construct name
-                (ForallHeader a)             -- Header information
-                [ Block a ]                  -- Body
-                (Maybe (Expression a))       -- Label to END DO
+                (Maybe (Expression a))       -- ^ Label
+                (Maybe String)               -- ^ Construct name
+                (ForallHeader a)             -- ^ Header information
+                [ Block a ]                  -- ^ Body
+                (Maybe (Expression a))       -- ^ Label to END DO
 
   | BlIf        a SrcSpan
-                (Maybe (Expression a))       -- Label
-                (Maybe String)               -- Construct name
-                [ Maybe (Expression a) ]     -- Conditions
-                [ [ Block a ] ]              -- Bodies
-                (Maybe (Expression a))       -- Label to END IF
+                (Maybe (Expression a))       -- ^ Label
+                (Maybe String)               -- ^ Construct name
+                [ Maybe (Expression a) ]     -- ^ Conditions
+                [ [ Block a ] ]              -- ^ Bodies
+                (Maybe (Expression a))       -- ^ Label to END IF
 
   | BlCase      a SrcSpan
-                (Maybe (Expression a))       -- Label
-                (Maybe String)               -- Construct name
-                (Expression a)               -- Scrutinee
-                [ Maybe (AList Index a) ]    -- Case ranges
-                [ [ Block a ] ]              -- Bodies
-                (Maybe (Expression a))       -- Label to END SELECT
+                (Maybe (Expression a))       -- ^ Label
+                (Maybe String)               -- ^ Construct name
+                (Expression a)               -- ^ Scrutinee
+                [ Maybe (AList Index a) ]    -- ^ Case ranges
+                [ [ Block a ] ]              -- ^ Bodies
+                (Maybe (Expression a))       -- ^ Label to END SELECT
 
   | BlDo        a SrcSpan
-                (Maybe (Expression a))       -- Label
-                (Maybe String)               -- Construct name
-                (Maybe (Expression a))       -- Target label
-                (Maybe (DoSpecification a))  -- Do Specification
-                [ Block a ]                  -- Body
-                (Maybe (Expression a))       -- Label to END DO
+                (Maybe (Expression a))       -- ^ Label
+                (Maybe String)               -- ^ Construct name
+                (Maybe (Expression a))       -- ^ Target label
+                (Maybe (DoSpecification a))  -- ^ Do Specification
+                [ Block a ]                  -- ^ Body
+                (Maybe (Expression a))       -- ^ Label to END DO
 
   | BlDoWhile   a SrcSpan
+                (Maybe (Expression a))       -- ^ Label
+                (Maybe String)               -- ^ Construct name
+                (Maybe (Expression a))       -- ^ Target label
+                (Expression a)               -- ^ Condition
+                [ Block a ]                  -- ^ Body
+                (Maybe (Expression a))       -- ^ Label to END DO
+
+  | BlAssociate a SrcSpan
                 (Maybe (Expression a))       -- Label
                 (Maybe String)               -- Construct name
-                (Maybe (Expression a))       -- Target label
-                (Expression a)               -- Condition
+                (AList (ATuple Expression Expression) a) -- Expression abbreviations
                 [ Block a ]                  -- Body
-                (Maybe (Expression a))       -- Label to END DO
+                (Maybe (Expression a))       -- Label to END IF
+  -- ^ The first 'Expression' in the abbreviation tuple is always an
+  --   @ExpValue _ _ (ValVariable id)@. Also guaranteed nonempty.
 
   | BlInterface a SrcSpan
-                (Maybe (Expression a))       -- label
-                Bool                         -- abstract?
-                [ ProgramUnit a ]            -- Routine decls. in the interface
-                [ Block a ]                  -- Module procedures
+                (Maybe (Expression a))       -- ^ label
+                Bool                         -- ^ abstract?
+                [ ProgramUnit a ]            -- ^ Routine decls. in the interface
+                [ Block a ]                  -- ^ Module procedures
 
   | BlComment a SrcSpan (Comment a)
   deriving (Eq, Show, Data, Typeable, Generic, Functor)
@@ -377,6 +386,7 @@
   | StExternal            a SrcSpan (AList Expression a)
   | StIntrinsic           a SrcSpan (AList Expression a)
   | StCommon              a SrcSpan (AList CommonGroup a)
+  -- ^ A COMMON statement, defining a list of common blocks.
   | StEquivalence         a SrcSpan (AList (AList Expression) a)
   | StFormat              a SrcSpan (AList FormatItem a)
   | StImplicit            a SrcSpan (Maybe (AList ImpList a))
@@ -393,10 +403,6 @@
   | StExit                a SrcSpan (Maybe (Expression a))
   | StIfLogical           a SrcSpan (Expression a) (Statement a) -- Statement should not further recurse
   | StIfArithmetic        a SrcSpan (Expression a) (Expression a) (Expression a) (Expression a)
-  | StIfThen              a SrcSpan (Maybe String) (Expression a)
-  | StElse                a SrcSpan (Maybe String)
-  | StElsif               a SrcSpan (Maybe String) (Expression a)
-  | StEndif               a SrcSpan (Maybe String)
   | StSelectCase          a SrcSpan (Maybe String) (Expression a)
   | StCase                a SrcSpan (Maybe String) (Maybe (AList Index a))
   | StEndcase             a SrcSpan (Maybe String)
@@ -522,8 +528,10 @@
   | ImpRange        a SrcSpan String String
   deriving (Eq, Show, Data, Typeable, Generic, Functor)
 
+-- | Note that the 'Declarator's in common group definitions do not contain
+--   initializing expressions.
 data CommonGroup a =
-  CommonGroup a SrcSpan (Maybe (Expression a)) (AList Expression a)
+  CommonGroup a SrcSpan (Maybe (Expression a)) (AList Declarator a)
   deriving (Eq, Show, Data, Typeable, Generic, Functor)
 
 data Namelist a =
@@ -572,7 +580,7 @@
   | ExpBinary        a SrcSpan BinaryOp (Expression a) (Expression a)
   -- ^ A binary operator applied to two expressions.
   | ExpUnary         a SrcSpan UnaryOp (Expression a)
-  -- ^ A unary operator applied to two expressions.
+  -- ^ A unary operator applied to one expression.
   | ExpSubscript     a SrcSpan (Expression a) (AList Index a)
   -- ^ Array indexing
   | ExpDataRef       a SrcSpan (Expression a) (Expression a)
@@ -590,9 +598,9 @@
 data Index a =
     IxSingle a SrcSpan (Maybe String) (Expression a)
   | IxRange a SrcSpan
-            (Maybe (Expression a)) -- Lower index
-            (Maybe (Expression a)) -- Upper index
-            (Maybe (Expression a)) -- Stride
+            (Maybe (Expression a)) -- ^ Lower index
+            (Maybe (Expression a)) -- ^ Upper index
+            (Maybe (Expression a)) -- ^ Stride
   deriving (Eq, Show, Data, Typeable, Generic, Functor)
 
 -- All recursive Values
@@ -653,14 +661,14 @@
 -- not enforced by the AST or parser, so be warned.
 data Declarator a =
     DeclVariable a SrcSpan
-                 (Expression a) -- ^ Variable
-                 (Maybe (Expression a)) -- ^ Length (character)
-                 (Maybe (Expression a)) -- ^ Initial value
+                 (Expression a)             -- ^ Variable
+                 (Maybe (Expression a))     -- ^ Length (character)
+                 (Maybe (Expression a))     -- ^ Initial value
   | DeclArray a SrcSpan
-              (Expression a) -- ^ Array
+              (Expression a)                -- ^ Array
               (AList DimensionDeclarator a) -- ^ Dimensions
-              (Maybe (Expression a)) -- ^ Length (character)
-              (Maybe (Expression a)) -- ^ Initial value
+              (Maybe (Expression a))        -- ^ Length (character)
+              (Maybe (Expression a))        -- ^ Initial value
   deriving (Eq, Show, Data, Typeable, Generic, Functor)
 
 setInitialisation :: Declarator a -> Expression a -> Declarator a
@@ -869,18 +877,6 @@
   setLabel (BlDo a s _ mn tl spec bs el) l = BlDo a s (Just l) mn tl spec bs el
   setLabel (BlDoWhile a s _ n tl spec bs el) l = BlDoWhile a s (Just l) n tl spec bs el
   setLabel b _ = b
-
-class Conditioned f where
-  getCondition :: f a -> Maybe (Expression a)
-
-instance Conditioned Block where
-  getCondition (BlStatement _ _ _ s) = getCondition s
-  getCondition _ = Nothing
-
-instance Conditioned Statement where
-  getCondition (StIfThen _ _ _ c) = Just c
-  getCondition (StElsif _ _ _ c) = Just c
-  getCondition _ = Nothing
 
 data ProgramUnitName =
     Named String
diff --git a/src/Language/Fortran/AST/AList.hs b/src/Language/Fortran/AST/AList.hs
--- a/src/Language/Fortran/AST/AList.hs
+++ b/src/Language/Fortran/AST/AList.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveFunctor #-}
 
 module Language.Fortran.AST.AList where
 
@@ -63,3 +64,14 @@
 
 aMap :: (t a -> r a) -> AList t a -> AList r a
 aMap f (AList a s xs) = AList a s (map f xs)
+
+--------------------------------------------------------------------------------
+
+data ATuple t1 t2 a = ATuple a SrcSpan (t1 a) (t2 a)
+    deriving (Eq, Show, Data, Typeable, Generic, Functor)
+
+instance FirstParameter (ATuple t1 t2 a) a
+instance SecondParameter (ATuple t1 t2 a) SrcSpan
+instance Spanned (ATuple t1 t2 a)
+instance (Out a, Out (t1 a), Out (t2 a)) => Out (ATuple t1 t2 a)
+instance (NFData a, NFData (t1 a), NFData (t2 a)) => NFData (ATuple t1 t2 a)
diff --git a/src/Language/Fortran/Analysis/BBlocks.hs b/src/Language/Fortran/Analysis/BBlocks.hs
--- a/src/Language/Fortran/Analysis/BBlocks.hs
+++ b/src/Language/Fortran/Analysis/BBlocks.hs
@@ -559,8 +559,6 @@
 stripNestedBlocks (BlDoWhile a s l tl n e _ el)  = BlDoWhile a s l tl n e [] el
 stripNestedBlocks (BlIf a s l mn exps _ el)      = BlIf a s l mn exps [] el
 stripNestedBlocks (BlCase a s l mn sc inds _ el) = BlCase a s l mn sc inds [] el
-stripNestedBlocks (BlStatement a s l
-                   (StIfLogical a' s' e _))      = BlStatement a s l (StIfLogical a' s' e (StEndif a' s' Nothing))
 stripNestedBlocks b                              = b
 
 -- Flatten out function calls within the expression, returning an
diff --git a/src/Language/Fortran/Analysis/SemanticTypes.hs b/src/Language/Fortran/Analysis/SemanticTypes.hs
--- a/src/Language/Fortran/Analysis/SemanticTypes.hs
+++ b/src/Language/Fortran/Analysis/SemanticTypes.hs
@@ -49,13 +49,13 @@
 -- TypeSpec?
 instance Pretty SemType where
   pprint' v = \case
-    TInteger k -> "integer"
-    TReal k    -> "real"
-    TComplex k -> "complex"
-    TLogical k -> "logical"
-    TByte k    -> "byte"
-    TCharacter len k -> "character"
-    TArray st dims -> pprint' v st <+> parens "(A)"
+    TInteger _ -> "integer"
+    TReal _    -> "real"
+    TComplex _ -> "complex"
+    TLogical _ -> "logical"
+    TByte _    -> "byte"
+    TCharacter _ _ -> "character"
+    TArray st _ -> pprint' v st <+> parens "(A)"
     TCustom str -> pprint' v (TypeCustom str)
 
 -- | The declared dimensions of a staticically typed array variable
diff --git a/src/Language/Fortran/Analysis/Types.hs b/src/Language/Fortran/Analysis/Types.hs
--- a/src/Language/Fortran/Analysis/Types.hs
+++ b/src/Language/Fortran/Analysis/Types.hs
@@ -21,7 +21,7 @@
 import Data.Map (insert)
 import qualified Data.Map as M
 import Data.Maybe (maybeToList)
-import Data.List (find)
+import Data.List (find, foldl')
 import Control.Monad.State.Strict
 import Data.Generics.Uniplate.Data
 import Data.Data
@@ -41,6 +41,10 @@
 -- | Information about a detected type error.
 type TypeError = (String, SrcSpan)
 
+-- | Mapping of structures to field types
+type StructTypeEnv = M.Map Name StructMemberTypeEnv
+type StructMemberTypeEnv = M.Map Name IDType
+
 --------------------------------------------------
 
 -- Monad for type inference work
@@ -48,6 +52,7 @@
 data InferState = InferState { langVersion :: FortranVersion
                              , intrinsics  :: IntrinsicsTable
                              , environ     :: TypeEnv
+                             , structs     :: StructTypeEnv
                              , entryPoints :: M.Map Name (Name, Maybe Name)
                              , typeErrors  :: [TypeError] }
   deriving Show
@@ -167,41 +172,68 @@
                                    , let ub = do ExpValue _ _ (ValInteger i) <- ubExp
                                                  return $ read i ]
 
-statement :: Data a => InferFunc (Statement (Analysis a))
-
-statement (StDeclaration _ stmtSs ts@(TypeSpec _ _ _ _) mAttrAList declAList)
+-- | Auxiliary function for getting semantic and construct type of a declaration.
+-- Used in standard declarations and structures
+handleDeclaration :: Data a => TypeEnv -> SrcSpan -> TypeSpec (Analysis a)
+  -> Maybe (AList Attribute (Analysis a))
+  -> AList Declarator (Analysis a)
+  -> Infer [(Name, SemType, ConstructType)]
+handleDeclaration env stmtSs ts mAttrAList declAList
   | mAttrs  <- maybe [] aStrip mAttrAList
   , attrDim <- find isAttrDimension mAttrs
   , isParam <- any isAttrParameter mAttrs
   , isExtrn <- any isAttrExternal mAttrs
-  , decls   <- aStrip declAList = do
-    env <- gets environ
+  , decls   <- aStrip declAList =
     let cType n | isExtrn                                     = CTExternal
                 | Just (AttrDimension _ _ ddAList) <- attrDim = CTArray (dimDeclarator ddAList)
                 | isParam                                     = CTParameter
                 | Just (IDType _ (Just ct)) <- M.lookup n env
                 , ct /= CTIntrinsic                           = ct
                 | otherwise                                   = CTVariable
-    forM_ decls $ \ decl -> case decl of
-        DeclArray _ declSs v ddAList mLenExpr _ -> do
-            let ct = CTArray $ dimDeclarator ddAList
+        handler rs = \case
+          DeclArray _ declSs v ddAList mLenExpr _ -> do
             st <- deriveSemTypeFromDeclaration stmtSs declSs ts mLenExpr
-            recordType st ct (varName v)
-        DeclVariable _ declSs v mLenExpr _      -> do
+            pure $ (varName v, st, CTArray  $ dimDeclarator ddAList) : rs
+          DeclVariable _ declSs v mLenExpr _ -> do
             st <- deriveSemTypeFromDeclaration stmtSs declSs ts mLenExpr
-            recordType st (cType n) n where n = varName v
+            let n = varName v
+            pure $ (n, st, cType n) : rs
+    in foldM handler [] decls
 
+handleStructureItem :: Data a => StructMemberTypeEnv -> StructureItem (Analysis a) -> Infer StructMemberTypeEnv
+handleStructureItem mt (StructFields _ src ts mAttrAList declAList) = do
+  env <- gets environ
+  ds <- handleDeclaration env src ts mAttrAList declAList
+  pure $ foldl' (\m (n, s, c) -> M.insert n (IDType (Just s) (Just c)) m) mt ds
+-- TODO: These should eventually be implemented
+handleStructureItem mt StructUnion{} = pure mt
+handleStructureItem mt StructStructure{} = pure mt
+
+-- | Create a structure env from the list of fields and add it to the InferState
+handleStructure ::Data a => Maybe String -> AList StructureItem (Analysis a) -> Infer ()
+handleStructure mName itemAList = do
+  case mName of
+    Just n -> do
+      structEnv <- foldM handleStructureItem M.empty (aStrip itemAList)
+      recordStruct structEnv n
+    Nothing -> pure ()
+
+statement :: Data a => InferFunc (Statement (Analysis a))
+
+statement (StDeclaration _ stmtSs ts mAttrAList declAList) = do
+  env <- gets environ
+  decls <- handleDeclaration env stmtSs ts mAttrAList declAList
+  forM_ decls $ \(n, b, c) -> recordType b c n
 statement (StExternal _ _ varAList) = do
   let vars = aStrip varAList
   mapM_ (recordCType CTExternal . varName) vars
 statement (StExpressionAssign _ _ (ExpSubscript _ _ v ixAList) _)
   --  | any (not . isIxSingle) (aStrip ixAList) = recordCType CTArray (varName v)  -- it's an array (or a string?) FIXME
   | all isIxSingle (aStrip ixAList) = do
-    let n = varName v
-    mIDType <- getRecordedType n
+    mIDType <- getExprRecordedType v
     case mIDType of
       Just (IDType _ (Just CTArray{})) -> return ()                -- do nothing, it's already known to be an array
-      _                                -> recordCType CTFunction n -- assume it's a function statement
+      _                                -> recordCType CTFunction (varName v) -- assume it's a function statement
 
 -- FIXME: if StFunctions can only be identified after types analysis
 -- is complete and disambiguation is performed, then how do we get
@@ -216,6 +248,8 @@
     DeclArray _ _ v ddAList _ _ -> recordCType (CTArray $ dimDeclarator ddAList) (varName v)
     _                           -> return ()
 
+statement (StStructure _ _ mName itemAList) = handleStructure mName itemAList
+
 statement _ = return ()
 
 annotateExpression :: Data a => Expression (Analysis a) -> Infer (Expression (Analysis a))
@@ -417,7 +451,7 @@
 -- Monadic helper combinators.
 
 inferState0 :: FortranVersion -> InferState
-inferState0 v = InferState { environ = M.empty, entryPoints = M.empty, langVersion = v
+inferState0 v = InferState { environ = M.empty, structs = M.empty, entryPoints = M.empty, langVersion = v
                            , intrinsics = getVersionIntrinsics v, typeErrors = [] }
 runInfer :: FortranVersion -> TypeEnv -> State InferState a -> (a, InferState)
 runInfer v env = flip runState ((inferState0 v) { environ = env })
@@ -432,6 +466,9 @@
 recordType :: SemType -> ConstructType -> Name -> Infer ()
 recordType st ct n = modify $ \ s -> s { environ = insert n (IDType (Just st) (Just ct)) (environ s) }
 
+recordStruct :: StructMemberTypeEnv -> Name -> Infer ()
+recordStruct mt n = modify $ \s -> s { structs = insert n mt (structs s) }
+
 -- Record the type (maybe) of the given name.
 recordMType :: Maybe SemType -> Maybe ConstructType -> Name -> Infer ()
 recordMType st ct n = modify $ \ s -> s { environ = insert n (IDType st ct) (environ s) }
@@ -451,6 +488,24 @@
 
 getRecordedType :: Name -> Infer (Maybe IDType)
 getRecordedType n = gets (M.lookup n . environ)
+
+getExprRecordedType :: Data a => Expression (Analysis a) -> Infer (Maybe IDType)
+getExprRecordedType e@(ExpValue _ _ (ValVariable _)) = getRecordedType $ varName e
+getExprRecordedType (ExpSubscript _ _ base _) = do
+  mTy <- getExprRecordedType base
+  case mTy of
+    Just (IDType semTy (Just CTArray{})) -> pure . Just $ IDType semTy (Just CTVariable)
+    _ -> pure Nothing
+getExprRecordedType (ExpDataRef _ _ base ref) = do
+  mTy <- getExprRecordedType base
+  case mTy of
+    Just (IDType (Just (TCustom n)) _) -> do
+      mStructEnv <- gets (M.lookup n . structs)
+      case mStructEnv of
+        Nothing -> pure Nothing
+        Just env -> pure $ M.lookup (varName ref) env
+    x -> pure x
+getExprRecordedType _ = pure Nothing
 
 -- Set the idType annotation
 setIDType :: Annotated f => IDType -> f (Analysis a) -> f (Analysis a)
diff --git a/src/Language/Fortran/Lexer/FreeForm.x b/src/Language/Fortran/Lexer/FreeForm.x
--- a/src/Language/Fortran/Lexer/FreeForm.x
+++ b/src/Language/Fortran/Lexer/FreeForm.x
@@ -222,7 +222,7 @@
 <0> "do"                                          { addSpan TDo }
 <scN> "do" / { followsColonP }                    { addSpan TDo }
 <0> "end"\ *"do"                                  { addSpan TEndDo }
-<scN> "while" / { followsDoP }                    { addSpan TWhile }
+<scN> "while" / { followsDoWithOptLabelP }        { addSpan TWhile }
 <0> "if"                                          { addSpan TIf }
 <scN> "if" / { followsColonP }                    { addSpan TIf }
 <scI> "then"                                      { addSpan TThen }
@@ -244,6 +244,9 @@
 <0,scI> "pause"                                   { addSpan TPause }
 <0> "forall"                                      { addSpan TForall }
 <0> "end"\ *"forall"                              { addSpan TEndForall }
+<0> "associate"                                   { addSpan TAssociate }
+<scN> "associate" / { followsColonP }             { addSpan TAssociate }
+<0> "end"\ *"associate"                           { addSpan TEndAssociate }
 
 
 -- Where construct
@@ -334,10 +337,17 @@
   | Just TFormat{} <- aiPreviousToken ai = True
   | otherwise = False
 
-followsDoP :: User -> AlexInput -> Int -> AlexInput -> Bool
-followsDoP _ _ _ ai
-  | Just TDo {} <- aiPreviousToken ai = True
+followsDoWithOptLabelP :: User -> AlexInput -> Int -> AlexInput -> Bool
+followsDoWithOptLabelP _ _ _ ai
+  -- DO ...
+  | Just TDo {} <- aiPreviousToken ai        = True
+
+  -- DO 10 ...
+  | TDo{}:TIntegerLiteral{}:[] <- prevTokens = True
+
   | otherwise = False
+  where
+    prevTokens = reverse . aiPreviousTokensInLine $ ai
 
 followsColonP :: User -> AlexInput -> Int -> AlexInput -> Bool
 followsColonP _ _ _ ai
@@ -1276,6 +1286,8 @@
   | TExit               SrcSpan
   | TForall             SrcSpan
   | TEndForall          SrcSpan
+  | TAssociate          SrcSpan
+  | TEndAssociate       SrcSpan
   -- Where construct
   | TWhere              SrcSpan
   | TElsewhere          SrcSpan
diff --git a/src/Language/Fortran/Parser/Fortran2003.y b/src/Language/Fortran/Parser/Fortran2003.y
--- a/src/Language/Fortran/Parser/Fortran2003.y
+++ b/src/Language/Fortran/Parser/Fortran2003.y
@@ -1,8 +1,10 @@
 -- -*- Mode: Haskell -*-
+-- vim: ft=haskell
 {
 -- Incomplete work-in-progress.
 module Language.Fortran.Parser.Fortran2003 ( functionParser
                                            , statementParser
+                                           , blockParser
                                            , fortran2003Parser
                                            , fortran2003ParserWithTransforms
                                            , fortran2003ParserWithModFiles
@@ -32,9 +34,10 @@
 
 }
 
-%name programParser PROGRAM
+%name programParser   PROGRAM
+%name functionParser  SUBPROGRAM_UNIT
+%name blockParser     BLOCK
 %name statementParser STATEMENT
-%name functionParser SUBPROGRAM_UNIT
 %monad { LexAction }
 %lexer { lexer } { TEOF _ }
 %tokentype { Token }
@@ -158,6 +161,8 @@
   case                        { TCase _ }
   selectcase                  { TSelectCase _ }
   endselect                   { TEndSelect _ }
+  associate                   { TAssociate _ }
+  endassociate                { TEndAssociate _ }
   default                     { TDefault _ }
   cycle                       { TCycle _ }
   exit                        { TExit _ }
@@ -231,6 +236,10 @@
 
 %%
 
+maybe(p)
+: p           { Just $1 }
+| {- empty -} { Nothing }
+
 -- This rule is to ignore leading whitespace
 PROGRAM :: { ProgramFile A0 }
 : NEWLINE PROGRAM_INNER { $2 }
@@ -346,13 +355,16 @@
 NAME :: { Name } : id { let (TId _ name) = $1 in name }
 
 IMPORT_NAME_LIST :: { [Expression A0] }
-: IMPORT_NAME_LIST ',' VARIABLE { $3:$1 }
-| VARIABLE { [$1] }
+: IMPORT_NAME_LIST ',' VARIABLE { $3 : $1 }
+| VARIABLE { [ $1 ] }
 
 BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }
 
 BLOCK :: { Block A0 }
-: INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE
+: IF_BLOCK MAYBE_COMMENT NEWLINE { $1 }
+| CASE_BLOCK MAYBE_COMMENT NEWLINE { $1 }
+| ASSOCIATE_BLOCK MAYBE_COMMENT NEWLINE { $1 }
+| INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE
   { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
 | STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }
 | ABSTRACTP interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE SUBPROGRAM_UNITS2 MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE
@@ -361,6 +373,144 @@
   { BlInterface () (getTransSpan $2 $9) $3 $1 [ ] (reverse $6) }
 | COMMENT_BLOCK { $1 }
 
+IF_BLOCK :: { Block A0 }
+:                        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { startSpan = getSpan $1;
+          (endSpan, conds, blocks, endLabel) = $9;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span Nothing Nothing ((Just $3):conds) ((reverse $8):blocks) endLabel }
+|                 id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { TId startSpan startName = $1;
+          (endSpan, conds, blocks, endLabel) = $11;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span Nothing (Just startName) ((Just $5):conds) ((reverse $10):blocks) endLabel }
+| INTEGER_LITERAL        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { startSpan = getSpan $1;
+          startLabel = Just $1;
+          (endSpan, conds, blocks, endLabel) = $10;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span startLabel Nothing ((Just $4):conds) ((reverse $9):blocks) endLabel }
+| INTEGER_LITERAL id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { startSpan = getSpan $1;
+          startLabel = Just $1;
+          TId _ startName = $2;
+          (endSpan, conds, blocks, endLabel) = $12;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }
+
+ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }
+: maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let (endSpan, conds, blocks, endLabel) = $10
+    in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }
+| maybe(INTEGER_LITERAL) else                          MAYBE_COMMENT NEWLINE BLOCKS END_IF
+  { let (endSpan, endLabel) = $6
+    in (endSpan, [Nothing], [reverse $5], endLabel) }
+| END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }
+
+END_IF :: { (SrcSpan, Maybe (Expression A0)) }
+: endif { (getSpan $1, Nothing) }
+| endif id { (getSpan $2, Nothing) }
+| INTEGER_LITERAL endif { (getSpan $2, Just $1) }
+| INTEGER_LITERAL endif id { (getSpan $3, Just $1) }
+
+CASE_BLOCK :: { Block A0 }
+:                        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $7;
+          span = getTransSpan $1 endSpan }
+    in BlCase () span Nothing Nothing $3 caseRanges blocks endLabel }
+| INTEGER_LITERAL        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $8;
+          span = getTransSpan $1 endSpan }
+    in BlCase () span (Just $1) Nothing $4 caseRanges blocks endLabel }
+|                 id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $9;
+          TId s startName = $1;
+          span = getTransSpan s endSpan }
+    in BlCase () span Nothing (Just startName) $5 caseRanges blocks endLabel }
+| INTEGER_LITERAL id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $10;
+          TId s startName = $2;
+          span = getTransSpan s endSpan }
+    in BlCase () span (Just $1) (Just startName) $6 caseRanges blocks endLabel }
+
+-- We store line comments as statements, but this raises an issue: we have
+-- nowhere to place comments after a SELECT CASE but before a CASE. So we drop
+-- them. The inner CASES_ rule does /not/ use this, because comments can always
+-- be parsed as belonging to to the above CASE block.
+CASES :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }
+: COMMENT_BLOCK CASES_ { $2 }
+|               CASES_ { $1 }
+
+CASES_ :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }
+: maybe(INTEGER_LITERAL) case '(' INDICIES ')' MAYBE_COMMENT NEWLINE BLOCKS CASES_
+  { let (scrutinees, blocks, endLabel, endSpan) = $9
+    in  (Just (fromReverseList $4) : scrutinees, reverse $8 : blocks, endLabel, endSpan) }
+| maybe(INTEGER_LITERAL) case default          MAYBE_COMMENT NEWLINE BLOCKS END_SELECT
+  { let (endLabel, endSpan) = $7
+    in ([Nothing], [$6], endLabel, endSpan) }
+| END_SELECT
+  { let (endLabel, endSpan) = $1
+    in ([], [], endLabel, endSpan) }
+
+END_SELECT :: { (Maybe (Expression A0), SrcSpan) }
+: maybe(INTEGER_LITERAL) endselect maybe(id)
+  { ($1, maybe (getSpan $2) getSpan $3) }
+
+ASSOCIATE_BLOCK :: { Block A0 }
+: INTEGER_LITERAL id ':' associate '(' ABBREVIATIONS ')' MAYBE_COMMENT NEWLINE BLOCKS END_ASSOCIATE
+  { let { startSpan  = getSpan $1;
+          mLabel     = Just $1;
+          TId _ name = $2;
+          mName      = Just name;
+          abbrevs    = fromReverseList $6;
+          body       = reverse $10;
+          (endSpan, mEndLabel) = $11;
+          span       = getTransSpan startSpan endSpan }
+     in BlAssociate () span mLabel mName abbrevs body mEndLabel }
+| INTEGER_LITERAL        associate '(' ABBREVIATIONS ')' MAYBE_COMMENT NEWLINE BLOCKS END_ASSOCIATE
+  { let { startSpan  = getSpan $1;
+          mLabel     = Just $1;
+          mName      = Nothing;
+          abbrevs    = fromReverseList $4;
+          body       = reverse $8;
+          (endSpan, mEndLabel) = $9;
+          span       = getTransSpan startSpan endSpan }
+     in BlAssociate () span mLabel mName abbrevs body mEndLabel }
+|                 id ':' associate '(' ABBREVIATIONS ')' MAYBE_COMMENT NEWLINE BLOCKS END_ASSOCIATE
+  { let { startSpan  = getSpan $1;
+          TId _ name = $1;
+          mLabel     = Nothing;
+          mName      = Just name;
+          abbrevs    = fromReverseList $5;
+          body       = reverse $9;
+          (endSpan, mEndLabel) = $10;
+          span       = getTransSpan startSpan endSpan }
+     in BlAssociate () span mLabel mName abbrevs body mEndLabel }
+|                        associate '(' ABBREVIATIONS ')' MAYBE_COMMENT NEWLINE BLOCKS END_ASSOCIATE
+  { let { startSpan  = getSpan $1;
+          mLabel     = Nothing;
+          mName      = Nothing;
+          abbrevs    = fromReverseList $3;
+          body       = reverse $7;
+          (endSpan, mEndLabel) = $8;
+          span       = getTransSpan startSpan endSpan }
+     in BlAssociate () span mLabel mName abbrevs body mEndLabel }
+
+-- TODO: Copied verbatim from END_IF. Should attempt to functionalise.
+END_ASSOCIATE :: { (SrcSpan, Maybe (Expression A0)) }
+: endassociate { (getSpan $1, Nothing) }
+| endassociate id { (getSpan $2, Nothing) }
+| INTEGER_LITERAL endassociate { (getSpan $2, Just $1) }
+| INTEGER_LITERAL endassociate id { (getSpan $3, Just $1) }
+
+-- (var (ExpValue (ValVariable)), assoc. expr)
+ABBREVIATIONS :: { [(ATuple Expression Expression A0)] }
+: ABBREVIATIONS ',' ABBREVIATION { $3 : $1 }
+| ABBREVIATION { [ $1 ] }
+
+ABBREVIATION :: { ATuple Expression Expression A0 }
+: VARIABLE '=>' EXPRESSION { ATuple () (getTransSpan $1 $3) $1 $3 }
+
 ABSTRACTP :: { Bool }
 : abstract { True }
 | {- EMPTY -} { False }
@@ -435,25 +585,25 @@
 | procedure '(' MAYBE_PROC_INTERFACE ')' MAYBE_DCOLON PROC_DECLS
   { let declAList = fromReverseList $6
     in StProcedure () (getTransSpan $1 $6) $3 Nothing declAList }
-| dimension MAYBE_DCOLON DECLARATOR_LIST
+| dimension MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
   { let declAList = fromReverseList $3
     in StDimension () (getTransSpan $1 declAList) declAList }
-| allocatable MAYBE_DCOLON DECLARATOR_LIST
+| allocatable MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
   { let declAList = fromReverseList $3
     in StAllocatable () (getTransSpan $1 declAList) declAList }
-| asynchronous MAYBE_DCOLON DECLARATOR_LIST
+| asynchronous MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
   { let declAList = fromReverseList $3
     in StAsynchronous () (getTransSpan $1 declAList) declAList }
-| pointer MAYBE_DCOLON DECLARATOR_LIST
+| pointer MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
   { let declAList = fromReverseList $3
     in StPointer () (getTransSpan $1 declAList) declAList }
-| target MAYBE_DCOLON DECLARATOR_LIST
+| target MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
   { let declAList = fromReverseList $3
     in StTarget () (getTransSpan $1 declAList) declAList }
-| value MAYBE_DCOLON DECLARATOR_LIST
+| value MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
   { let declAList = fromReverseList $3
     in StValue () (getTransSpan $1 declAList) declAList }
-| volatile MAYBE_DCOLON DECLARATOR_LIST
+| volatile MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
   { let declAList = fromReverseList $3
     in StVolatile () (getTransSpan $1 declAList) declAList }
 | data cDATA DATA_GROUPS cPOP
@@ -565,16 +715,6 @@
 | endwhere { StEndWhere () (getSpan $1) Nothing }
 | if '(' EXPRESSION ')' INTEGER_LITERAL ',' INTEGER_LITERAL ',' INTEGER_LITERAL
   { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }
-| if '(' EXPRESSION ')' then { StIfThen () (getTransSpan $1 $5) Nothing $3 }
-| id ':' if '(' EXPRESSION ')' then
-  { let TId s id = $1 in StIfThen () (getTransSpan s $7) (Just id) $5 }
-| elsif '(' EXPRESSION ')' then { StElsif () (getTransSpan $1 $5) Nothing $3 }
-| elsif '(' EXPRESSION ')' then id
-  { let TId s id = $6 in StElsif () (getTransSpan $1 s) (Just id) $3 }
-| else { StElse () (getSpan $1) Nothing }
-| else id { let TId s id = $2 in StElse () (getTransSpan $1 s) (Just id) }
-| endif { StEndif () (getSpan $1) Nothing }
-| endif id { let TId s id = $2 in StEndif () (getTransSpan $1 s) (Just id) }
 | do { StDo () (getSpan $1) Nothing Nothing Nothing }
 | id ':' do
   { let TId s id = $1
@@ -607,21 +747,6 @@
 | continue { StContinue () (getSpan $1) }
 | stop { StStop () (getSpan $1) Nothing }
 | stop EXPRESSION { StStop () (getTransSpan $1 $2) (Just $2) }
-| selectcase '(' EXPRESSION ')'
-  { StSelectCase () (getTransSpan $1 $4) Nothing $3 }
-| id ':' selectcase '(' EXPRESSION ')'
-  { let TId s id = $1 in StSelectCase () (getTransSpan s $6) (Just id) $5 }
-| case default { StCase () (getTransSpan $1 $2) Nothing Nothing }
-| case default id
-  { let TId s id = $3 in StCase () (getTransSpan $1 s) (Just id) Nothing }
-| case '(' INDICIES ')'
-  { StCase () (getTransSpan $1 $4) Nothing (Just $ fromReverseList $3) }
-| case '(' INDICIES ')' id
-  { let TId s id = $5
-    in StCase () (getTransSpan $1 s) (Just id) (Just $ fromReverseList $3) }
-| endselect { StEndcase () (getSpan $1) Nothing }
-| endselect id
-  { let TId s id = $2 in StEndcase () (getTransSpan $1 s) (Just id) }
 | if '(' EXPRESSION ')' EXECUTABLE_STATEMENT
   { StIfLogical () (getTransSpan $1 $5) $3 $5 }
 | read CILIST IN_IOLIST
@@ -819,21 +944,21 @@
 | INIT_COMMON_GROUP { [ $1 ] }
 
 COMMON_GROUP :: { CommonGroup A0 }
-: COMMON_NAME PART_REFS
+: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST
   { let alist = fromReverseList $2
     in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }
-| '/' '/' PART_REFS
+| '/' '/' UNINITIALIZED_DECLARATOR_LIST
   { let alist = fromReverseList $3
     in CommonGroup () (getTransSpan $1 alist) Nothing alist }
 
 INIT_COMMON_GROUP :: { CommonGroup A0 }
-: COMMON_NAME PART_REFS
+: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST
   { let alist = fromReverseList $2
     in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }
-| '/' '/' PART_REFS
+| '/' '/' UNINITIALIZED_DECLARATOR_LIST
   { let alist = fromReverseList $3
     in CommonGroup () (getTransSpan $1 alist) Nothing alist }
-| PART_REFS
+| UNINITIALIZED_DECLARATOR_LIST
   { let alist = fromReverseList $1
     in CommonGroup () (getSpan alist) Nothing alist }
 
@@ -895,11 +1020,11 @@
   { DeclVariable () (getTransSpan $1 $3) $1 Nothing (Just $3) }
 
 DECLARATION_STATEMENT :: { Statement A0 }
-: TYPE_SPEC ATTRIBUTE_LIST '::' DECLARATOR_LIST
+: TYPE_SPEC ATTRIBUTE_LIST '::' INITIALIZED_DECLARATOR_LIST
   { let { mAttrAList = if null $2 then Nothing else Just $ fromReverseList $2;
           declAList = fromReverseList $4 }
     in StDeclaration () (getTransSpan $1 declAList) $1 mAttrAList declAList }
-| TYPE_SPEC DECLARATOR_LIST
+| TYPE_SPEC INITIALIZED_DECLARATOR_LIST
   { let { declAList = fromReverseList $2 }
     in StDeclaration () (getTransSpan $1 declAList) $1 Nothing declAList }
 
@@ -956,11 +1081,15 @@
 COMMON_NAME :: { Expression A0 }
 : '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 }
 
-DECLARATOR_LIST :: { [ Declarator A0 ] }
-: DECLARATOR_LIST ',' INITIALISED_DECLARATOR { $3 : $1 }
-| INITIALISED_DECLARATOR { [ $1 ] }
+INITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }
+: INITIALIZED_DECLARATOR_LIST ',' INITIALIZED_DECLARATOR { $3 : $1 }
+| INITIALIZED_DECLARATOR { [ $1 ] }
 
-INITIALISED_DECLARATOR :: { Declarator A0 }
+UNINITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }
+: UNINITIALIZED_DECLARATOR_LIST ',' DECLARATOR { $3 : $1 }
+| DECLARATOR { [ $1 ] }
+
+INITIALIZED_DECLARATOR :: { Declarator A0 }
 : DECLARATOR '=' EXPRESSION { setInitialisation $1 $3 }
 | DECLARATOR '=>' EXPRESSION { setInitialisation $1 $3 }
 | DECLARATOR { $1 }
@@ -1194,45 +1323,38 @@
   StForallStatement () (getTransSpan $1 $3) h $3
 }
 
-FORALL_HEADER
-  :: { (ForallHeader A0, SrcSpan) }
-FORALL_HEADER :
-  -- Standard simple forall header
-    '(' FORALL_TRIPLET_SPEC ')'   { (ForallHeader [$2] Nothing, getTransSpan $1 $3) }
-  -- forall header with scale expression
-  | '(' '(' FORALL_TRIPLET_SPEC ')' ',' EXPRESSION ')'
-                                  { (ForallHeader [$3] (Just $6), getTransSpan $1 $7) }
-  -- multi forall header
-  | '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ')'
-                                  { (ForallHeader $2 Nothing, getTransSpan $1 $3) }
-  -- multi forall header with scale
-  | '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ',' EXPRESSION ')'
-                                  { (ForallHeader $2 (Just $4), getTransSpan $1 $5) }
+FORALL_HEADER :: { (ForallHeader A0, SrcSpan) }
+-- Standard simple forall header
+: '(' FORALL_TRIPLET_SPEC ')'   { (ForallHeader [$2] Nothing, getTransSpan $1 $3) }
+-- forall header with scale expression
+| '(' '(' FORALL_TRIPLET_SPEC ')' ',' EXPRESSION ')'
+                              { (ForallHeader [$3] (Just $6), getTransSpan $1 $7) }
+-- multi forall header
+| '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ')'
+                              { (ForallHeader $2 Nothing, getTransSpan $1 $3) }
+-- multi forall header with scale
+| '(' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE ',' EXPRESSION ')'
+                              { (ForallHeader $2 (Just $4), getTransSpan $1 $5) }
 
 FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE
   :: { [(Name, Expression A0, Expression A0, Maybe (Expression A0))] }
-FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE
 : '(' FORALL_TRIPLET_SPEC ')' ',' FORALL_TRIPLET_SPEC_LIST_PLUS_STRIDE { $2 : $5 }
 | {- empty -}                                                          { [] }
 
 FORALL_TRIPLET_SPEC :: { (Name, Expression A0, Expression A0, Maybe (Expression A0)) }
-FORALL_TRIPLET_SPEC
 : NAME '=' EXPRESSION ':' EXPRESSION { ($1, $3, $5, Nothing) }
 | NAME '=' EXPRESSION ':' EXPRESSION ',' EXPRESSION { ($1, $3, $5, Just $7) }
 
 FORALL_ASSIGNMENT_STMT :: { Statement A0 }
-FORALL_ASSIGNMENT_STMT :
-    EXPRESSION_ASSIGNMENT_STATEMENT { $1 }
-  | POINTER_ASSIGNMENT_STMT { $1 }
+: EXPRESSION_ASSIGNMENT_STATEMENT { $1 }
+| POINTER_ASSIGNMENT_STMT { $1 }
 
 POINTER_ASSIGNMENT_STMT :: { Statement A0 }
-POINTER_ASSIGNMENT_STMT :
- DATA_REF '=>' EXPRESSION { StPointerAssign () (getTransSpan $1 $3) $1 $3 }
+: DATA_REF '=>' EXPRESSION { StPointerAssign () (getTransSpan $1 $3) $1 $3 }
 
 END_FORALL :: { Statement A0 }
-END_FORALL :
-   endforall    { StEndForall () (getSpan $1) Nothing }
- | endforall id { let (TId s id) = $2 in StEndForall () (getTransSpan $1 s) (Just id)}
+: endforall    { StEndForall () (getSpan $1) Nothing }
+| endforall id { let (TId s id) = $2 in StEndForall () (getTransSpan $1 s) (Just id)}
 
 EXPRESSION_LIST :: { [ Expression A0 ] }
 : EXPRESSION_LIST ',' EXPRESSION { $3 : $1 }
diff --git a/src/Language/Fortran/Parser/Fortran66.y b/src/Language/Fortran/Parser/Fortran66.y
--- a/src/Language/Fortran/Parser/Fortran66.y
+++ b/src/Language/Fortran/Parser/Fortran66.y
@@ -288,16 +288,16 @@
 
 COMMON_GROUP :: { CommonGroup A0 }
 COMMON_GROUP
-: COMMON_NAME NAME_LIST
+: COMMON_NAME DECLARATORS
   { CommonGroup () (getTransSpan $1 $2) (Just $1) $ aReverse $2 }
-| '/' '/' NAME_LIST { CommonGroup () (getTransSpan $1 $3) Nothing $ aReverse $3 }
+| '/' '/' DECLARATORS { CommonGroup () (getTransSpan $1 $3) Nothing $ aReverse $3 }
 
 INIT_COMMON_GROUP :: { CommonGroup A0 }
 INIT_COMMON_GROUP
-: COMMON_NAME NAME_LIST
+: COMMON_NAME DECLARATORS
   { CommonGroup () (getTransSpan $1 $2) (Just $1) $ aReverse $2 }
-| '/' '/' NAME_LIST { CommonGroup () (getTransSpan $1 $3) Nothing $ aReverse $3 }
-| NAME_LIST { CommonGroup () (getSpan $1) Nothing $ aReverse $1 }
+| '/' '/' DECLARATORS { CommonGroup () (getTransSpan $1 $3) Nothing $ aReverse $3 }
+| DECLARATORS { CommonGroup () (getSpan $1) Nothing $ aReverse $1 }
 
 COMMON_NAME :: { Expression A0 }
 COMMON_NAME : '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 }
@@ -309,6 +309,7 @@
 
 NAME_LIST_ELEMENT :: { Expression A0 } : VARIABLE { $1 } | SUBSCRIPT { $1 }
 
+-- Note that declarator lists in the F66 parser don't have initializers.
 DECLARATORS :: { AList Declarator A0 }
 DECLARATORS
 : DECLARATORS ',' DECLARATOR { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }
diff --git a/src/Language/Fortran/Parser/Fortran77.y b/src/Language/Fortran/Parser/Fortran77.y
--- a/src/Language/Fortran/Parser/Fortran77.y
+++ b/src/Language/Fortran/Parser/Fortran77.y
@@ -1,8 +1,11 @@
 -- -*- Mode: Haskell -*-
+-- vim: ft=haskell
 {
+{-# LANGUAGE TupleSections #-}
 module Language.Fortran.Parser.Fortran77
   ( expressionParser
   , statementParser
+  , blockParser
   , fortran77Parser
   , fortran77ParserWithTransforms
   , fortran77ParserWithModFiles
@@ -44,6 +47,7 @@
 
 %name programParser PROGRAM
 %name includesParser INCLUDES
+%name blockParser BLOCK
 %name statementParser STATEMENT
 %name expressionParser EXPRESSION
 %monad { LexAction }
@@ -200,22 +204,18 @@
 
 -- This rule is to ignore leading whitespace
 PROGRAM :: { ProgramFile A0 }
-PROGRAM
 : NEWLINE PROGRAM_INNER { $2 }
 | PROGRAM_INNER { $1 }
 
 PROGRAM_INNER :: { ProgramFile A0 }
-PROGRAM_INNER
 : PROGRAM_UNITS { ProgramFile (MetaInfo { miVersion = Fortran77, miFilename = "" }) (reverse $1) }
 | {- empty -}   { ProgramFile (MetaInfo { miVersion = Fortran77, miFilename = "" }) [] }
 
 PROGRAM_UNITS :: { [ ProgramUnit A0 ] }
-PROGRAM_UNITS
 : PROGRAM_UNITS maybe(LABEL_IN_6COLUMN) PROGRAM_UNIT maybe(NEWLINE) { $3 : $1 }
 | maybe(LABEL_IN_6COLUMN) PROGRAM_UNIT maybe(NEWLINE) { [ $2 ] }
 
 PROGRAM_UNIT :: { ProgramUnit A0 }
-PROGRAM_UNIT
 : program NAME NEWLINE BLOCKS ENDPROG
   { PUMain () (getTransSpan $1 $5) (Just $2) (reverse $4) Nothing }
 | TYPE_SPEC function NAME MAYBE_ARGUMENTS NEWLINE BLOCKS ENDFUN
@@ -229,24 +229,20 @@
 | comment { let (TComment s c) = $1 in PUComment () s (Comment c) }
 
 END :: { Token }
-END
 : end                  { $1 }
 | LABEL_IN_6COLUMN end { $2 }
 
 ENDPROG :: { Token }
-ENDPROG
 : END                         { $1 }
 | endprogram MAYBE_ID       { $1 }
 | LABEL_IN_6COLUMN endprogram MAYBE_ID { $2 }
 
 ENDFUN :: { Token }
-ENDFUN
 : END                          { $1 }
 | endfunction MAYBE_ID       { $1 }
 | LABEL_IN_6COLUMN endfunction MAYBE_ID { $2 }
 
 ENDSUB :: { Token }
-ENDSUB
 : END                            { $1 }
 | endsubroutine MAYBE_ID       { $1 }
 | LABEL_IN_6COLUMN endsubroutine MAYBE_ID { $2 }
@@ -262,61 +258,67 @@
 NAME :: { Name } : id { let (TId _ name) = $1 in name }
 
 INCLUDES :: { [ Block A0 ] }
-INCLUDES
 : maybe(NEWLINE) list(BLOCK) { $2 }
 
 BLOCKS :: { [ Block A0 ] }
-BLOCKS
 : BLOCKS BLOCK { $2 : $1 }
 | {- EMPTY -} { [ ] }
 
 BLOCK :: { Block A0 }
-BLOCK
-: LABEL_IN_6COLUMN STATEMENT NEWLINE { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
+: IF_BLOCK NEWLINE { $1 }
+| LABEL_IN_6COLUMN STATEMENT NEWLINE { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
 | STATEMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }
 | COMMENT_BLOCK { $1 }
 
+IF_BLOCK :: { Block A0 }
+: if '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS {
+    let (endSpan, endLabel, conds, blocks) = $8
+    in BlIf () (getTransSpan $1 endSpan) Nothing Nothing ((Just $3):conds) ((reverse $7):blocks) endLabel
+  }
+| LABEL_IN_6COLUMN if '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS {
+    let (endSpan, endLabel, conds, blocks) = $9
+    in BlIf () (getTransSpan $1 endSpan) (Just $1) Nothing ((Just $4):conds) ((reverse $8):blocks) endLabel
+  }
+
+ELSE_BLOCKS :: { (SrcSpan, Maybe (Expression A0), [Maybe (Expression A0)], [[Block A0]]) }
+: maybe(LABEL_IN_6COLUMN) elsif '(' EXPRESSION ')' then NEWLINE BLOCKS ELSE_BLOCKS
+  { let (endSpan, endLabel, conds, blocks) = $9
+    in (endSpan, endLabel, Just $4 : conds, reverse $8 : blocks) }
+| maybe(LABEL_IN_6COLUMN) else NEWLINE BLOCKS maybe(LABEL_IN_6COLUMN) endif
+  { (getSpan $6, $5, [Nothing], [reverse $4]) }
+| maybe(LABEL_IN_6COLUMN) endif { (getSpan $2, $1, [], []) }
+
 COMMENT_BLOCK :: { Block A0 }
-COMMENT_BLOCK
 : comment NEWLINE { let (TComment s c) = $1 in BlComment () s (Comment c) }
 
 NEWLINE :: { Token }
-NEWLINE
 : NEWLINE newline { $1 }
 | newline { $1 }
 
 STATEMENT :: { Statement A0 }
-STATEMENT
 : LOGICAL_IF_STATEMENT { $1 }
 | DO_STATEMENT { $1 }
 | EXECUTABLE_STATEMENT { $1 }
 | NONEXECUTABLE_STATEMENT { $1 }
 
 LOGICAL_IF_STATEMENT :: { Statement A0 }
-LOGICAL_IF_STATEMENT : if '(' EXPRESSION ')' EXECUTABLE_STATEMENT { StIfLogical () (getTransSpan $1 $5) $3 $5 }
+: if '(' EXPRESSION ')' EXECUTABLE_STATEMENT { StIfLogical () (getTransSpan $1 $5) $3 $5 }
 
 DO_STATEMENT :: { Statement A0 }
-DO_STATEMENT
 : do LABEL_IN_STATEMENT DO_SPECIFICATION { StDo () (getTransSpan $1 $3) Nothing (Just $2) (Just $3) }
 | do LABEL_IN_STATEMENT ',' DO_SPECIFICATION { StDo () (getTransSpan $1 $4) Nothing (Just $2) (Just $4) }
 | do DO_SPECIFICATION { StDo () (getTransSpan $1 $2) Nothing Nothing (Just $2) }
 | do { StDo () (getSpan $1) Nothing Nothing Nothing }
 
 DO_SPECIFICATION :: { DoSpecification A0 }
-DO_SPECIFICATION
 : EXPRESSION_ASSIGNMENT_STATEMENT ',' EXPRESSION ',' EXPRESSION { DoSpecification () (getTransSpan $1 $5) $1 $3 (Just $5) }
 | EXPRESSION_ASSIGNMENT_STATEMENT ',' EXPRESSION                { DoSpecification () (getTransSpan $1 $3) $1 $3 Nothing }
 
 EXECUTABLE_STATEMENT :: { Statement A0 }
-EXECUTABLE_STATEMENT
 : EXPRESSION_ASSIGNMENT_STATEMENT { $1 }
 | assign LABEL_IN_STATEMENT to VARIABLE { StLabelAssign () (getTransSpan $1 $4) $2 $4 }
 | GOTO_STATEMENT { $1 }
 | if '(' EXPRESSION ')' LABEL_IN_STATEMENT ',' LABEL_IN_STATEMENT ',' LABEL_IN_STATEMENT { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }
-| if '(' EXPRESSION ')' then { StIfThen () (getTransSpan $1 $5) Nothing $3 }
-| elsif '(' EXPRESSION ')' then { StElsif () (getTransSpan $1 $5) Nothing $3 }
-| else { StElse () (getSpan $1) Nothing }
-| endif { StEndif () (getSpan $1) Nothing }
 | doWhile '(' EXPRESSION ')'
   { StDoWhile () (getTransSpan $1 $4) Nothing Nothing $3 }
 | do LABEL_IN_STATEMENT while '(' EXPRESSION ')'
@@ -372,7 +374,6 @@
 | backspace UNIT { StBackspace2 () (getTransSpan $1 $2) $2 }
 
 FORMAT_ID :: { Expression A0 }
-FORMAT_ID
 : FORMAT_ID '/' '/' FORMAT_ID %prec CONCAT { ExpBinary () (getTransSpan $1 $4) Concatenation $1 $4 }
 | INTEGER_LITERAL               { $1 }
 -- There should be FUNCTION_CALL here but as far as the parser is concerned it is same as SUBSCRIPT,
@@ -381,7 +382,6 @@
 | '*' { ExpValue () (getSpan $1) ValStar }
 
 UNIT :: { Expression A0 }
-UNIT
 : INTEGER_LITERAL { $1 }
 | SUBSCRIPT { $1 }
 | '*' { ExpValue () (getSpan $1) ValStar }
@@ -389,7 +389,6 @@
 -- A crude approximation that makes parsing easy. Individual key value pairs
 -- should be checket later on.
 CILIST :: { AList ControlPair A0 }
-CILIST
 : '(' UNIT ',' FORMAT_ID ',' CILIST_PAIRS ')' {
   let { cp1 = ControlPair () (getSpan $2) Nothing $2;
         cp2 = ControlPair () (getSpan $4) Nothing $4 }
@@ -411,20 +410,17 @@
 | '(' CILIST_PAIRS ')' { setSpan (getTransSpan $1 $3) $ aReverse $2 }
 
 CILIST_PAIRS :: { AList ControlPair A0 }
-CILIST_PAIRS
 : CILIST_PAIRS ',' CILIST_PAIR { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }
 | CILIST_PAIR { AList () (getSpan $1) [ $1 ] }
 
 CILIST_PAIR :: { ControlPair A0 }
-CILIST_PAIR : id '=' CILIST_ELEMENT { let (TId s id) = $1 in ControlPair () (getTransSpan s $3) (Just id) $3 }
+: id '=' CILIST_ELEMENT { let (TId s id) = $1 in ControlPair () (getTransSpan s $3) (Just id) $3 }
 
 CILIST_ELEMENT :: { Expression A0 }
-CILIST_ELEMENT
 : CI_EXPRESSION { $1 }
 | '*' { ExpValue () (getSpan $1) ValStar }
 
 CI_EXPRESSION :: { Expression A0 }
-CI_EXPRESSION
 : CI_EXPRESSION '+' CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Addition $1 $3 }
 | CI_EXPRESSION '-' CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Subtraction $1 $3 }
 | CI_EXPRESSION '*' CI_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 }
@@ -452,37 +448,31 @@
 -- rule separation.
 
 IN_IOLIST :: { AList Expression A0 }
-IN_IOLIST
 : IN_IOLIST ',' IN_IO_ELEMENT { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1}
 | IN_IO_ELEMENT { AList () (getSpan $1) [ $1 ] }
 
 IN_IO_ELEMENT :: { Expression A0 }
-IN_IO_ELEMENT
 : SUBSCRIPT { $1 }
 | '(' IN_IOLIST ',' DO_SPECIFICATION ')' { ExpImpliedDo () (getTransSpan $1 $5) (aReverse $2) $4 }
 
 OUT_IOLIST :: { AList Expression A0 }
-OUT_IOLIST
 : OUT_IOLIST ',' EXPRESSION { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1}
 | EXPRESSION { AList () (getSpan $1) [ $1 ] }
 
 SAVE_ARGS :: { Maybe (AList Expression A0) }
-SAVE_ARGS
 : SAVE_ARGS_LEVEL1 { Just $ fromReverseList $1 }
 | {-EMPTY-} { Nothing }
 
 SAVE_ARGS_LEVEL1 :: { [ Expression A0 ] }
-SAVE_ARGS_LEVEL1
 : SAVE_ARGS_LEVEL1 ',' SAVE_ARG { $3 : $1 }
 | SAVE_ARG { [ $1 ] }
 
 SAVE_ARG :: { Expression A0 }
-SAVE_ARG : COMMON_NAME { $1 } | VARIABLE { $1 }
+: COMMON_NAME { $1 } | VARIABLE { $1 }
 
 INTEGER_OR_STRING :: { Expression A0 } : STRING { $1 } | INTEGER_LITERAL { $1 }
 
 GOTO_STATEMENT :: { Statement A0 }
-GOTO_STATEMENT
 : goto LABEL_IN_STATEMENT { StGotoUnconditional () (getTransSpan $1 $2) $2 }
 | goto VARIABLE { StGotoAssigned () (getTransSpan $1 $2) $2 Nothing }
 | goto VARIABLE LABELS_IN_STATEMENT { StGotoAssigned () (getTransSpan $1 $3) $2 (Just $3) }
@@ -491,19 +481,18 @@
 | goto LABELS_IN_STATEMENT ',' EXPRESSION { StGotoComputed () (getTransSpan $1 $4) $2 $4 }
 
 EXPRESSION_ASSIGNMENT_STATEMENT :: { Statement A0 }
-EXPRESSION_ASSIGNMENT_STATEMENT : ELEMENT '=' EXPRESSION { StExpressionAssign () (getTransSpan $1 $3) $1 $3 }
+: ELEMENT '=' EXPRESSION { StExpressionAssign () (getTransSpan $1 $3) $1 $3 }
 
 NONEXECUTABLE_STATEMENT :: { Statement A0 }
-NONEXECUTABLE_STATEMENT
 : external FUNCTION_NAMES { StExternal () (getTransSpan $1 $2) (aReverse $2) }
 | intrinsic FUNCTION_NAMES { StIntrinsic () (getTransSpan $1 $2) (aReverse $2) }
-| dimension ARRAY_DECLARATORS { StDimension () (getTransSpan $1 $2) (aReverse $2) }
+| dimension INITIALIZED_ARRAY_DECLARATORS { StDimension () (getTransSpan $1 $2) (aReverse $2) }
 | common COMMON_GROUPS { StCommon () (getTransSpan $1 $2) (aReverse $2) }
 | equivalence EQUIVALENCE_GROUPS { StEquivalence () (getTransSpan $1 $2) (aReverse $2) }
 | pointer POINTER_LIST { StPointer () (getTransSpan $1 $2) (fromReverseList $2) }
 | data DATA_GROUPS { StData () (getTransSpan $1 $2) (fromReverseList $2) }
-| automatic DECLARATORS { StAutomatic () (getTransSpan $1 $2) (aReverse $2) }
-| static DECLARATORS { StStatic () (getTransSpan $1 $2) (aReverse $2) }
+| automatic INITIALIZED_DECLARATORS { StAutomatic () (getTransSpan $1 $2) (aReverse $2) }
+| static INITIALIZED_DECLARATORS { StStatic () (getTransSpan $1 $2) (aReverse $2) }
 -- Following is a fake node to make arbitrary FORMAT statements parsable.
 -- Must be fixed in the future. TODO
 | format blob
@@ -520,18 +509,15 @@
   { StStructure () (getTransSpan $1 $5) $2 (fromReverseList $4) }
 
 MAYBE_NAME :: { Maybe Name }
-MAYBE_NAME
 : '/' NAME '/' { Just $2 }
 | {- empty -}  { Nothing }
 
 STRUCTURE_DECLARATIONS :: { [StructureItem A0] }
-STRUCTURE_DECLARATIONS
 : STRUCTURE_DECLARATIONS STRUCTURE_DECLARATION_STATEMENT
   { if isNothing $2 then $1 else fromJust $2 : $1 }
 | STRUCTURE_DECLARATION_STATEMENT { if isNothing $1 then [] else [fromJust $1] }
 
 STRUCTURE_DECLARATION_STATEMENT :: { Maybe (StructureItem A0) }
-STRUCTURE_DECLARATION_STATEMENT
 : DECLARATION_STATEMENT NEWLINE
   { let StDeclaration () s t attrs decls = $1
     in Just $ StructFields () s t attrs decls }
@@ -542,62 +528,51 @@
 | comment NEWLINE { Nothing }
 
 UNION_MAPS :: { [ UnionMap A0 ] }
-UNION_MAPS
 : UNION_MAPS UNION_MAP { if isNothing $2 then $1 else fromJust $2 : $1 }
 | UNION_MAP { if isNothing $1 then [] else [fromJust $1] }
 
 UNION_MAP :: { Maybe (UnionMap A0) }
-UNION_MAP
 : map NEWLINE STRUCTURE_DECLARATIONS endmap NEWLINE
   { Just $ UnionMap () (getTransSpan $1 $5) (fromReverseList $3) }
 | comment NEWLINE { Nothing }
 
 ENTRY_ARGS :: { AList Expression A0 }
-ENTRY_ARGS
 : ENTRY_ARGS_LEVEL1 ')' { setSpan (getTransSpan $1 $2) $ aReverse $1 }
 
 ENTRY_ARGS_LEVEL1 :: { AList Expression A0 }
-ENTRY_ARGS_LEVEL1
 : ENTRY_ARGS_LEVEL1 ',' ENTRY_ARG { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }
 | '(' ENTRY_ARG { AList () (getTransSpan $1 $2) [ $2 ] }
 | '(' { AList () (getSpan $1) [ ] }
 
 ENTRY_ARG :: { Expression A0 }
-ENTRY_ARG
 : VARIABLE { $1 }
 | '*' { ExpValue () (getSpan $1) ValStar }
 
 PARAMETER_ASSIGNMENTS :: { [ Declarator A0 ] }
-PARAMETER_ASSIGNMENTS
 : PARAMETER_ASSIGNMENTS ',' PARAMETER_ASSIGNMENT { $3 : $1 }
 | PARAMETER_ASSIGNMENT { [ $1 ] }
 
 PARAMETER_ASSIGNMENT :: { Declarator A0 }
-PARAMETER_ASSIGNMENT
 : VARIABLE '=' CONSTANT_EXPRESSION
   { DeclVariable () (getTransSpan $1 $3) $1 Nothing (Just $3) }
 
 DECLARATION_STATEMENT :: { Statement A0 }
-DECLARATION_STATEMENT
-: TYPE_SPEC maybe(',') DECLARATORS { StDeclaration () (getTransSpan $1 $3) $1 Nothing (aReverse $3) }
+: TYPE_SPEC maybe(',') INITIALIZED_DECLARATORS
+  { StDeclaration () (getTransSpan $1 $3) $1 Nothing (aReverse $3) }
 
 IMP_LISTS :: { AList ImpList A0 }
-IMP_LISTS
 : IMP_LISTS ',' IMP_LIST { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }
 | IMP_LIST { AList () (getSpan $1) [ $1 ] }
 
 IMP_LIST :: { ImpList A0 }
-IMP_LIST
 : IMP_TYPE_SPEC '(' IMP_ELEMENTS ')'
   { ImpList () (getTransSpan $1 $4) $1 $ aReverse $3 }
 
 IMP_ELEMENTS :: { AList ImpElement A0 }
-IMP_ELEMENTS
 : IMP_ELEMENTS ',' IMP_ELEMENT { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }
 | IMP_ELEMENT { AList () (getSpan $1) [ $1 ] }
 
 IMP_ELEMENT :: { ImpElement A0 }
-IMP_ELEMENT
 : id {% do
       let (TId s id) = $1
       if length id /= 1
@@ -613,38 +588,31 @@
              }
 
 ELEMENT :: { Expression A0 }
-ELEMENT
 : SUBSCRIPT { $1 }
 
 DATA_GROUPS :: { [DataGroup A0] }
-DATA_GROUPS
 : DATA_GROUPS ',' DATA_GROUP { $3 : $1 }
 | DATA_GROUPS DATA_GROUP     { $2 : $1 }
 | DATA_GROUP                 { [$1] }
 
 DATA_GROUP :: { DataGroup A0 }
-DATA_GROUP
 : DATA_NAMES  '/' DATA_ITEMS '/' { DataGroup () (getTransSpan $1 $4) (aReverse $1) (aReverse $3) }
 
 DATA_NAMES :: { AList Expression A0 }
-DATA_NAMES
 : NAME_LIST  { $1 }
 | IMPLIED_DO { fromList () [ $1 ] }
 
 DATA_ITEMS :: { AList Expression A0 }
-DATA_ITEMS
 : DATA_ITEMS ',' DATA_ITEM { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1}
 | DATA_ITEM { AList () (getSpan $1) [ $1 ] }
 
 DATA_ITEM :: { Expression A0 }
-DATA_ITEM
 : INTEGER_CONSTANT '*' DATA_ITEM_LEVEL1 { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 }
 | DATA_ITEM_LEVEL1 { $1 }
 
 DATA_ITEM_LEVEL1 :: { Expression A0 }
-DATA_ITEM_LEVEL1
 : SIGNED_NUMERIC_LITERAL  { $1 }
---| COMPLEX_LITERAL         { $1 }
+-- | COMPLEX_LITERAL         { $1 }
 | VARIABLE                { $1 }
 | '(' SIGNED_NUMERIC_LITERAL ',' SIGNED_NUMERIC_LITERAL ')' { ExpValue () (getTransSpan $1 $5) (ValComplex $2 $4)}
 | LOGICAL_LITERAL         { $1 }
@@ -652,94 +620,102 @@
 | HOLLERITH               { $1 }
 
 EQUIVALENCE_GROUPS :: { AList (AList Expression) A0 }
-EQUIVALENCE_GROUPS
 : EQUIVALENCE_GROUPS ','  '(' NAME_LIST ')' { setSpan (getTransSpan $1 $5) $ (setSpan (getTransSpan $3 $5) $ aReverse $4) `aCons` $1 }
 | '(' NAME_LIST ')' { let s = (getTransSpan $1 $3) in AList () s [ setSpan s $ aReverse $2 ] }
 
 POINTER_LIST :: { [ Declarator A0 ] }
-POINTER_LIST
-: POINTER_LIST ',' POINTER
-  { $3 : $1 }
-| POINTER
-  { [ $1 ] }
+: POINTER_LIST ',' POINTER { $3 : $1 }
+| POINTER                  { [ $1 ] }
 
 POINTER :: { Declarator A0 }
 : '(' VARIABLE ',' VARIABLE ')'
   { DeclVariable () (getTransSpan $1 $5) $2 Nothing (Just $4) }
 
 COMMON_GROUPS :: { AList CommonGroup A0 }
-COMMON_GROUPS
 : COMMON_GROUPS COMMON_GROUP { setSpan (getTransSpan $1 $2) $ $2 `aCons` $1 }
 | INIT_COMMON_GROUP { AList () (getSpan $1) [ $1 ] }
 
 COMMON_GROUP :: { CommonGroup A0 }
-COMMON_GROUP
-: COMMON_NAME NAME_LIST { CommonGroup () (getTransSpan $1 $2) (Just $1) $ aReverse $2 }
-| '/' '/' NAME_LIST { CommonGroup () (getTransSpan $1 $3) Nothing $ aReverse $3 }
+: COMMON_NAME UNINITIALIZED_DECLARATORS { CommonGroup () (getTransSpan $1 $2) (Just $1) $ aReverse $2 }
+| '/' '/' UNINITIALIZED_DECLARATORS { CommonGroup () (getTransSpan $1 $3) Nothing $ aReverse $3 }
 
 INIT_COMMON_GROUP :: { CommonGroup A0 }
-INIT_COMMON_GROUP
-: COMMON_NAME NAME_LIST { CommonGroup () (getTransSpan $1 $2) (Just $1) $ aReverse $2 }
-| '/' '/' NAME_LIST { CommonGroup () (getTransSpan $1 $3) Nothing $ aReverse $3 }
-| NAME_LIST { CommonGroup () (getSpan $1) Nothing $ aReverse $1 }
+: COMMON_NAME UNINITIALIZED_DECLARATORS { CommonGroup () (getTransSpan $1 $2) (Just $1) $ aReverse $2 }
+| '/' '/' UNINITIALIZED_DECLARATORS { CommonGroup () (getTransSpan $1 $3) Nothing $ aReverse $3 }
+| UNINITIALIZED_DECLARATORS { CommonGroup () (getSpan $1) Nothing $ aReverse $1 }
 
 COMMON_NAME :: { Expression A0 }
-COMMON_NAME : '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 }
+: '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 }
 
 NAME_LIST :: { AList Expression A0 }
-NAME_LIST
 : NAME_LIST ',' ELEMENT
   { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }
 | ELEMENT { AList () (getSpan $1) [ $1 ] }
 
-DECLARATORS :: { AList Declarator A0 }
-DECLARATORS
-: DECLARATORS ',' DECLARATOR { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }
-| DECLARATOR { AList () (getSpan $1) [ $1 ] }
-
-DECLARATOR :: { Declarator A0 }
-DECLARATOR
-: ARRAY_DECLARATOR { $1 }
-| VARIABLE_DECLARATOR { $1 }
+UNINITIALIZED_DECLARATORS :: { AList Declarator A0 }
+: UNINITIALIZED_DECLARATORS ',' UNINITIALIZED_DECLARATOR { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }
+| UNINITIALIZED_DECLARATOR { AList () (getSpan $1) [ $1 ] }
 
-ARRAY_DECLARATORS :: { AList Declarator A0 }
-ARRAY_DECLARATORS
-: ARRAY_DECLARATORS ',' ARRAY_DECLARATOR
-  { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }
-| ARRAY_DECLARATOR { AList () (getSpan $1) [ $1 ] }
+UNINITIALIZED_DECLARATOR :: { Declarator A0 }
+: UNINITIALIZED_ARRAY_DECLARATOR { $1 }
+| UNINITIALIZED_VARIABLE_DECLARATOR { $1 }
 
-ARRAY_DECLARATOR :: { Declarator A0 }
-ARRAY_DECLARATOR
+UNINITIALIZED_ARRAY_DECLARATOR :: { Declarator A0 }
 : VARIABLE '(' DIMENSION_DECLARATORS ')'
   { DeclArray () (getTransSpan $1 $4) $1 (aReverse $3) Nothing Nothing }
+| VARIABLE '*' SIMPLE_EXPRESSION '(' DIMENSION_DECLARATORS ')'
+  { DeclArray () (getTransSpan $1 $6) $1 (aReverse $5) (Just $3) Nothing }
+| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' SIMPLE_EXPRESSION
+  { DeclArray () (getTransSpan $1 $6) $1 (aReverse $3) (Just $6) Nothing }
+
+UNINITIALIZED_VARIABLE_DECLARATOR :: { Declarator A0 }
+: VARIABLE { DeclVariable () (getSpan $1) $1 Nothing Nothing }
+| VARIABLE '*' SIMPLE_EXPRESSION
+  { DeclVariable () (getTransSpan $1 $3) $1 (Just $3) Nothing }
+
+INITIALIZED_DECLARATORS :: { AList Declarator A0 }
+: INITIALIZED_DECLARATORS ',' INITIALIZED_DECLARATOR { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }
+| INITIALIZED_DECLARATOR { AList () (getSpan $1) [ $1 ] }
+
+INITIALIZED_DECLARATOR :: { Declarator A0 }
+: INITIALIZED_ARRAY_DECLARATOR { $1 }
+| INITIALIZED_VARIABLE_DECLARATOR { $1 }
+
+INITIALIZED_ARRAY_DECLARATORS :: { AList Declarator A0 }
+: INITIALIZED_ARRAY_DECLARATORS ',' INITIALIZED_ARRAY_DECLARATOR
+  { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }
+| INITIALIZED_ARRAY_DECLARATOR { AList () (getSpan $1) [ $1 ] }
+
+INITIALIZED_ARRAY_DECLARATOR :: { Declarator A0 }
+: UNINITIALIZED_ARRAY_DECLARATOR { $1 }
 | VARIABLE '(' DIMENSION_DECLARATORS ')' '/' SIMPLE_EXPRESSION_LIST '/'
   { DeclArray () (getTransSpan $1 $7) $1 (aReverse $3) Nothing
     (Just (ExpInitialisation () (getSpan $6) (fromReverseList $6))) }
-| VARIABLE '*' SIMPLE_EXPRESSION '(' DIMENSION_DECLARATORS ')'
-  { DeclArray () (getTransSpan $1 $6) $1 (aReverse $5) (Just $3) Nothing }
 | VARIABLE '*' SIMPLE_EXPRESSION '(' DIMENSION_DECLARATORS ')' '/' SIMPLE_EXPRESSION_LIST '/'
   { DeclArray () (getTransSpan $1 $9) $1 (aReverse $5) (Just $3)
     (Just (ExpInitialisation () (getSpan $8) (fromReverseList $8))) }
-| VARIABLE '(' DIMENSION_DECLARATORS ')' '*' SIMPLE_EXPRESSION
-  { DeclArray () (getTransSpan $1 $6) $1 (aReverse $3) (Just $6) Nothing }
 | VARIABLE '(' DIMENSION_DECLARATORS ')' '*' SIMPLE_EXPRESSION '/' SIMPLE_EXPRESSION_LIST '/'
   { DeclArray () (getTransSpan $1 $9) $1 (aReverse $3) (Just $6)
     (Just (ExpInitialisation () (getSpan $8) (fromReverseList $8))) }
 
+INITIALIZED_VARIABLE_DECLARATOR :: { Declarator A0 }
+: UNINITIALIZED_VARIABLE_DECLARATOR { $1 }
+| VARIABLE '/' SIMPLE_EXPRESSION '/'
+  { DeclVariable () (getTransSpan $1 $4) $1 Nothing (Just $3) }
+| VARIABLE '*' SIMPLE_EXPRESSION '/' SIMPLE_EXPRESSION '/'
+  { DeclVariable () (getTransSpan $1 $6) $1 (Just $3) (Just $5) }
+
 SIMPLE_EXPRESSION_LIST :: { [Expression A0] }
-SIMPLE_EXPRESSION_LIST
 : SIMPLE_EXPRESSION_LIST ',' SIMPLE_EXPRESSION  { $3 : $1 }
 | SIMPLE_EXPRESSION { [ $1 ] }
 
 SIMPLE_EXPRESSION :: { Expression A0 }
-SIMPLE_EXPRESSION
 : INTEGER_CONSTANT '*' CONSTANT  { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 }
 | CONSTANT { $1 }
 | '(' '*' ')' { ExpValue () (getSpan $2) ValStar }
 | '(' EXPRESSION ')' { $2 }
 
 CONSTANT :: { Expression A0 }
-CONSTANT
 : VARIABLE { $1 }
 | SIGNED_NUMERIC_LITERAL { $1 }
 | LOGICAL_LITERAL { $1 }
@@ -747,28 +723,15 @@
 | HOLLERITH { $1 }
 
 INTEGER_CONSTANT :: { Expression A0 }
-INTEGER_CONSTANT
 : VARIABLE { $1 }
 | SIGNED_NUMERIC_LITERAL { $1 }
 
-VARIABLE_DECLARATOR :: { Declarator A0 }
-VARIABLE_DECLARATOR
-: VARIABLE { DeclVariable () (getSpan $1) $1 Nothing Nothing }
-| VARIABLE '*' SIMPLE_EXPRESSION
-  { DeclVariable () (getTransSpan $1 $3) $1 (Just $3) Nothing }
-| VARIABLE '/' SIMPLE_EXPRESSION '/'
-  { DeclVariable () (getTransSpan $1 $4) $1 Nothing (Just $3) }
-| VARIABLE '*' SIMPLE_EXPRESSION '/' SIMPLE_EXPRESSION '/'
-  { DeclVariable () (getTransSpan $1 $6) $1 (Just $3) (Just $5) }
-
 DIMENSION_DECLARATORS :: { AList DimensionDeclarator A0 }
-DIMENSION_DECLARATORS
 : DIMENSION_DECLARATORS ',' DIMENSION_DECLARATOR
   { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }
 | DIMENSION_DECLARATOR { AList () (getSpan $1) [ $1 ] }
 
 DIMENSION_DECLARATOR :: { DimensionDeclarator A0 }
-DIMENSION_DECLARATOR
 : EXPRESSION ':' EXPRESSION { DimensionDeclarator () (getTransSpan $1 $3) (Just $1) (Just $3) }
 | EXPRESSION { DimensionDeclarator () (getSpan $1) Nothing (Just $1) }
 | EXPRESSION ':' '*' { DimensionDeclarator () (getTransSpan $1 $3) (Just $1) (Just $ ExpValue () (getSpan $3) ValStar) }
@@ -778,23 +741,19 @@
 -- since they are syntactically identical at this stage subroutine names
 -- are also emitted as function names.
 FUNCTION_NAMES :: { AList Expression A0 }
-FUNCTION_NAMES
 : FUNCTION_NAMES ',' VARIABLE { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }
 | VARIABLE { AList () (getSpan $1) [ $1 ] }
 
 ARGUMENTS :: { AList Argument A0 }
-ARGUMENTS
 : ARGUMENTS_LEVEL1 ')' { setSpan (getTransSpan $1 $2) $ aReverse $1 }
 
 ARGUMENTS_LEVEL1 :: { AList Argument A0 }
-ARGUMENTS_LEVEL1
 : ARGUMENTS_LEVEL1 ',' CALLABLE_EXPRESSION { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }
 | '(' CALLABLE_EXPRESSION { AList () (getTransSpan $1 $2) [ $2 ] }
 | '(' { AList () (getSpan $1) [ ] }
 
 -- Expression all by itself subsumes all other callable expressions.
 CALLABLE_EXPRESSION :: { Argument A0 }
-CALLABLE_EXPRESSION
 -- Explicitly parse special intrinsics for argument passing types
 : '%' id '(' EXPRESSION ')'
   { let { args = AList () (getSpan $4) $ [Argument () (getSpan $4) Nothing $4];
@@ -809,7 +768,6 @@
 | EXPRESSION  { Argument () (getSpan $1) Nothing $1 }
 
 EXPRESSION :: { Expression A0 }
-EXPRESSION
 : EXPRESSION '+' EXPRESSION { ExpBinary () (getTransSpan $1 $3) Addition $1 $3 }
 | EXPRESSION '-' EXPRESSION { ExpBinary () (getTransSpan $1 $3) Subtraction $1 $3 }
 | EXPRESSION '*' EXPRESSION { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 }
@@ -842,7 +800,6 @@
 | '&' INTEGER_LITERAL { ExpReturnSpec () (getTransSpan $1 $2) $2 }
 
 IMPLIED_DO :: { Expression A0 }
-IMPLIED_DO
 : '(' EXPRESSION ',' DO_SPECIFICATION ')' {
     let expList = AList () (getSpan $2) [ $2 ]
           in ExpImpliedDo () (getTransSpan $1 $5) expList $4
@@ -858,14 +815,12 @@
          }
 
 EXPRESSION_LIST :: { [ Expression A0 ] }
-EXPRESSION_LIST
 : EXPRESSION_LIST ',' EXPRESSION { $3 : $1 }
 | EXPRESSION { [ $1 ] }
 
 STRING :: { Expression A0 } : string { let (TString s cs) = $1 in ExpValue () s (ValString cs) }
 
 CONSTANT_EXPRESSION :: { Expression A0 }
-CONSTANT_EXPRESSION
 : CONSTANT_EXPRESSION '+' CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Addition $1 $3 }
 | CONSTANT_EXPRESSION '-' CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Subtraction $1 $3 }
 | CONSTANT_EXPRESSION '*' CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 }
@@ -891,7 +846,6 @@
           }
 
 ARITHMETIC_CONSTANT_EXPRESSION :: { Expression A0 }
-ARITHMETIC_CONSTANT_EXPRESSION
 : ARITHMETIC_CONSTANT_EXPRESSION '+' ARITHMETIC_CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Addition $1 $3 }
 | ARITHMETIC_CONSTANT_EXPRESSION '-' ARITHMETIC_CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Subtraction $1 $3 }
 | ARITHMETIC_CONSTANT_EXPRESSION '*' ARITHMETIC_CONSTANT_EXPRESSION { ExpBinary () (getTransSpan $1 $3) Multiplication $1 $3 }
@@ -905,7 +859,6 @@
 | SUBSCRIPT                    { $1 }
 
 RELATIONAL_OPERATOR :: { BinaryOp }
-RELATIONAL_OPERATOR
 : '=='  { EQ }
 | '!='  { NE }
 | '>'   { GT }
@@ -914,7 +867,6 @@
 | '<='  { LTE }
 
 SUBSCRIPT :: { Expression A0 }
-SUBSCRIPT
 : SUBSCRIPT '.' VARIABLE
   { ExpDataRef () (getTransSpan $1 $3) $1 $3 }
 | SUBSCRIPT '%' VARIABLE
@@ -942,7 +894,6 @@
   { IxRange () (getTransSpan $1 $3) (Just $1) (Just $3) Nothing }
 
 ARITHMETIC_SIGN :: { (SrcSpan, UnaryOp) }
-ARITHMETIC_SIGN
 : '-' { (getSpan $1, Minus) }
 | '+' { (getSpan $1, Plus) }
 
@@ -950,12 +901,10 @@
 : VARIABLES { Just $ fromReverseList $1 } | {- EMPTY -} { Nothing }
 
 VARIABLES :: { [ Expression A0 ] }
-VARIABLES
 : VARIABLES ',' VARIABLE_OR_STAR { $3 : $1 }
 | VARIABLE_OR_STAR { [ $1 ] }
 
 VARIABLE_OR_STAR :: { Expression A0 }
-VARIABLE_OR_STAR
 : VARIABLE { $1 }
 | '*' { ExpValue () (getSpan $1) ValStar }
 | '&' { ExpValue () (getSpan $1) ValStar }
@@ -965,7 +914,6 @@
 -- this stage.
 -- This at least reduces reduce/reduce conflicts.
 VARIABLE :: { Expression A0 }
-VARIABLE
 : id { ExpValue () (getSpan $1) $ let (TId _ s) = $1 in ValVariable s }
 
 INTEGER_LITERAL :: { Expression A0 }
@@ -973,42 +921,35 @@
 | boz { let TBozInt s i = $1 in ExpValue () s $ ValInteger i }
 
 REAL_LITERAL :: { Expression A0 }
-REAL_LITERAL
 : int EXPONENT { makeReal (Just $1) Nothing Nothing (Just $2) }
 | int '.' MAYBE_EXPONENT { makeReal (Just $1) (Just $2) Nothing $3 }
 | '.' int MAYBE_EXPONENT { makeReal Nothing (Just $1) (Just $2) $3 }
 | int '.' int MAYBE_EXPONENT { makeReal (Just $1) (Just $2) (Just $3) $4 }
 
 MAYBE_EXPONENT :: { Maybe (SrcSpan, String) }
-MAYBE_EXPONENT
 : EXPONENT { Just $1 }
 | {-EMPTY-} { Nothing }
 
 EXPONENT :: { (SrcSpan, String) }
-EXPONENT
 : exponent { let (TExponent s exp) = $1 in (s, exp) }
 
 SIGNED_NUMERIC_LITERAL :: { Expression A0 }
-SIGNED_NUMERIC_LITERAL
 : ARITHMETIC_SIGN NUMERIC_LITERAL { ExpUnary () (getTransSpan (fst $1) $2) Minus $2 }
 | NUMERIC_LITERAL { $1 }
 
 NUMERIC_LITERAL :: { Expression A0 }
-NUMERIC_LITERAL
 : INTEGER_LITERAL { $1 }
 | REAL_LITERAL { $1 }
 
 LOGICAL_LITERAL :: { Expression A0 }
-LOGICAL_LITERAL : bool { let TBool s b = $1 in ExpValue () s $ ValLogical b }
+: bool { let TBool s b = $1 in ExpValue () s $ ValLogical b }
 
 HOLLERITH :: { Expression A0 } : hollerith { ExpValue () (getSpan $1) $ let (THollerith _ h) = $1 in ValHollerith h }
 
 LABELS_IN_STATEMENT :: { AList Expression A0 }
-LABELS_IN_STATEMENT
 : LABELS_IN_STATEMENT_LEVEL1 ')' { setSpan (getTransSpan $1 $2) $ aReverse $1 }
 
 LABELS_IN_STATEMENT_LEVEL1 :: { AList Expression A0 }
-LABELS_IN_STATEMENT_LEVEL1
 : LABELS_IN_STATEMENT_LEVEL1 ',' LABEL_IN_STATEMENT { setSpan (getTransSpan $1 $3) $ $3 `aCons` $1 }
 | '(' LABEL_IN_STATEMENT { AList () (getTransSpan $1 $2) [ $2 ] }
 
@@ -1019,7 +960,6 @@
 LABEL_IN_STATEMENT :: { Expression A0 } : int { ExpValue () (getSpan $1) (let (TInt _ l) = $1 in ValInteger l) }
 
 TYPE_SPEC :: { TypeSpec A0 }
-TYPE_SPEC
 : integer   KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeInteger $2 }
 | real      KIND_SELECTOR { TypeSpec () (getSpan ($1, $2)) TypeReal $2  }
 | doublePrecision         { TypeSpec () (getSpan $1)       TypeDoublePrecision Nothing}
@@ -1031,33 +971,25 @@
 | record    '/' NAME '/'  { TypeSpec () (getSpan ($1, $4)) (TypeCustom $3) Nothing }
 
 KIND_SELECTOR :: { Maybe (Selector A0) }
-KIND_SELECTOR
-: KIND_SELECTOR1
-  { Just $1 }
-| {- EMPTY -}
-  { Nothing }
+: KIND_SELECTOR1 { Just $1 }
+| {- EMPTY -}    { Nothing }
 
 KIND_SELECTOR1 :: { Selector A0 }
-KIND_SELECTOR1
 : '*' ARITHMETIC_CONSTANT_EXPRESSION
   { Selector () (getTransSpan $1 $2) Nothing (Just $2) }
 | '*' '(' STAR ')' { Selector () (getTransSpan $1 $4) Nothing (Just $3) }
 
 CHAR_SELECTOR :: { Maybe (Selector A0) }
-: CHAR_SELECTOR1
-  { Just $1 }
-| {- EMPTY -}
-  { Nothing }
+: CHAR_SELECTOR1 { Just $1 }
+| {- EMPTY -}    { Nothing }
 
 CHAR_SELECTOR1 :: { Selector A0 }
-CHAR_SELECTOR1
 : '*' ARITHMETIC_CONSTANT_EXPRESSION
   { Selector () (getTransSpan $1 $2) (Just $2) Nothing }
 | '*' '(' STAR ')'
   { Selector () (getTransSpan $1 $4) (Just $3) Nothing }
 
 IMP_TYPE_SPEC :: { TypeSpec A0 }
-IMP_TYPE_SPEC
 : TYPE_SPEC  { $1 }
 
 STAR :: { Expression A0 }
@@ -1194,8 +1126,8 @@
       case M.lookup path incMap of
         Just blocks' -> pure $ StInclude a s e (Just blocks')
         Nothing -> do
-          inc <- liftIO $ readInDirs dirs path
-          case includeParser fv inc path of
+          (fullPath, inc) <- liftIO $ readInDirs dirs path
+          case includeParser fv inc fullPath of
             ParseOk blocks _ -> do
               blocks' <- descendBiM (inlineInclude fv dirs (path:seen)) blocks
               modify (M.insert path blocks')
@@ -1204,12 +1136,13 @@
     else return st
   _ -> return st
 
-readInDirs :: [String] -> String -> IO B.ByteString
+readInDirs :: [String] -> String -> IO (String, B.ByteString)
 readInDirs [] f = fail $ "cannot find file: " ++ f
 readInDirs (d:ds) f = do
-  b <- doesFileExist (d</>f)
+  let path = d</>f
+  b <- doesFileExist path
   if b then
-    B.readFile (d</>f)
+    (path,) <$> B.readFile path
   else
     readInDirs ds f
 
diff --git a/src/Language/Fortran/Parser/Fortran90.y b/src/Language/Fortran/Parser/Fortran90.y
--- a/src/Language/Fortran/Parser/Fortran90.y
+++ b/src/Language/Fortran/Parser/Fortran90.y
@@ -2,6 +2,7 @@
 {
 module Language.Fortran.Parser.Fortran90 ( statementParser
                                          , functionParser
+                                         , blockParser
                                          , fortran90Parser
                                          , fortran90ParserWithTransforms
                                          , fortran90ParserWithModFiles
@@ -33,6 +34,7 @@
 %name programParser PROGRAM
 %name functionParser SUBPROGRAM_UNIT
 %name statementParser STATEMENT
+%name blockParser BLOCK
 %monad { LexAction }
 %lexer { lexer } { TEOF _ }
 %tokentype { Token }
@@ -206,6 +208,10 @@
 
 %%
 
+maybe(p)
+: p           { Just $1 }
+| {- empty -} { Nothing }
+
 -- This rule is to ignore leading whitespace
 PROGRAM :: { ProgramFile A0 }
 : NEWLINE PROGRAM_INNER { $2 }
@@ -299,7 +305,9 @@
 BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }
 
 BLOCK :: { Block A0 }
-: INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE
+: IF_BLOCK MAYBE_COMMENT NEWLINE { $1 }
+| CASE_BLOCK MAYBE_COMMENT NEWLINE { $1 }
+| INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE
   { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
 | STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }
 | interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE SUBPROGRAM_UNITS2 MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE
@@ -308,6 +316,89 @@
   { BlInterface () (getTransSpan $1 $8) $2 False [ ] (reverse $5) }
 | COMMENT_BLOCK { $1 }
 
+IF_BLOCK :: { Block A0 }
+:                        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { startSpan = getSpan $1;
+          (endSpan, conds, blocks, endLabel) = $9;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span Nothing Nothing ((Just $3):conds) ((reverse $8):blocks) endLabel }
+|                 id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { TId startSpan startName = $1;
+          (endSpan, conds, blocks, endLabel) = $11;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span Nothing (Just startName) ((Just $5):conds) ((reverse $10):blocks) endLabel }
+| INTEGER_LITERAL        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { startSpan = getSpan $1;
+          startLabel = Just $1;
+          (endSpan, conds, blocks, endLabel) = $10;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span startLabel Nothing ((Just $4):conds) ((reverse $9):blocks) endLabel }
+| INTEGER_LITERAL id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { startSpan = getSpan $1;
+          startLabel = Just $1;
+          TId _ startName = $2;
+          (endSpan, conds, blocks, endLabel) = $12;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }
+
+ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }
+: maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let (endSpan, conds, blocks, endLabel) = $10
+    in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }
+| maybe(INTEGER_LITERAL) else                          MAYBE_COMMENT NEWLINE BLOCKS END_IF
+  { let (endSpan, endLabel) = $6
+    in (endSpan, [Nothing], [reverse $5], endLabel) }
+| END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }
+
+END_IF :: { (SrcSpan, Maybe (Expression A0)) }
+: endif { (getSpan $1, Nothing) }
+| endif id { (getSpan $2, Nothing) }
+| INTEGER_LITERAL endif { (getSpan $2, Just $1) }
+| INTEGER_LITERAL endif id { (getSpan $3, Just $1) }
+
+CASE_BLOCK :: { Block A0 }
+:                        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $7;
+          span = getTransSpan $1 endSpan }
+    in BlCase () span Nothing Nothing $3 caseRanges blocks endLabel }
+| INTEGER_LITERAL        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $8;
+          span = getTransSpan $1 endSpan }
+    in BlCase () span (Just $1) Nothing $4 caseRanges blocks endLabel }
+|                 id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $9;
+          TId s startName = $1;
+          span = getTransSpan s endSpan }
+    in BlCase () span Nothing (Just startName) $5 caseRanges blocks endLabel }
+| INTEGER_LITERAL id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $10;
+          TId s startName = $2;
+          span = getTransSpan s endSpan }
+    in BlCase () span (Just $1) (Just startName) $6 caseRanges blocks endLabel }
+
+-- We store line comments as statements, but this raises an issue: we have
+-- nowhere to place comments after a SELECT CASE but before a CASE. So we drop
+-- them. The inner CASES_ rule does /not/ use this, because comments can always
+-- be parsed as belonging to to the above CASE block.
+CASES :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }
+: COMMENT_BLOCK CASES_ { $2 }
+|               CASES_ { $1 }
+
+CASES_ :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }
+: maybe(INTEGER_LITERAL) case '(' INDICIES ')' MAYBE_COMMENT NEWLINE BLOCKS CASES_
+  { let (scrutinees, blocks, endLabel, endSpan) = $9
+    in  (Just (fromReverseList $4) : scrutinees, reverse $8 : blocks, endLabel, endSpan) }
+| maybe(INTEGER_LITERAL) case default          MAYBE_COMMENT NEWLINE BLOCKS END_SELECT
+  { let (endLabel, endSpan) = $7
+    in ([Nothing], [$6], endLabel, endSpan) }
+| END_SELECT
+  { let (endLabel, endSpan) = $1
+    in ([], [], endLabel, endSpan) }
+
+END_SELECT :: { (Maybe (Expression A0), SrcSpan) }
+: maybe(INTEGER_LITERAL) endselect maybe(id)
+  { ($1, maybe (getSpan $2) getSpan $3) }
+
 MAYBE_EXPRESSION :: { Maybe (Expression A0) }
 : EXPRESSION { Just $1 }
 | {- EMPTY -} { Nothing }
@@ -368,16 +459,16 @@
   { let saveAList = (fromReverseList $3)
     in StSave () (getTransSpan $1 saveAList) (Just saveAList) }
 | save { StSave () (getSpan $1) Nothing }
-| dimension MAYBE_DCOLON DECLARATOR_LIST
+| dimension MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
   { let declAList = fromReverseList $3
     in StDimension () (getTransSpan $1 declAList) declAList }
-| allocatable MAYBE_DCOLON DECLARATOR_LIST
+| allocatable MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
   { let declAList = fromReverseList $3
     in StAllocatable () (getTransSpan $1 declAList) declAList }
-| pointer MAYBE_DCOLON DECLARATOR_LIST
+| pointer MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
   { let declAList = fromReverseList $3
     in StPointer () (getTransSpan $1 declAList) declAList }
-| target MAYBE_DCOLON DECLARATOR_LIST
+| target MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
   { let declAList = fromReverseList $3
     in StTarget () (getTransSpan $1 declAList) declAList }
 | data cDATA DATA_GROUPS cPOP
@@ -450,16 +541,6 @@
 | endwhere { StEndWhere () (getSpan $1) Nothing }
 | if '(' EXPRESSION ')' INTEGER_LITERAL ',' INTEGER_LITERAL ',' INTEGER_LITERAL
   { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }
-| if '(' EXPRESSION ')' then { StIfThen () (getTransSpan $1 $5) Nothing $3 }
-| id ':' if '(' EXPRESSION ')' then
-  { let TId s id = $1 in StIfThen () (getTransSpan s $7) (Just id) $5 }
-| elsif '(' EXPRESSION ')' then { StElsif () (getTransSpan $1 $5) Nothing $3 }
-| elsif '(' EXPRESSION ')' then id
-  { let TId s id = $6 in StElsif () (getTransSpan $1 s) (Just id) $3 }
-| else { StElse () (getSpan $1) Nothing }
-| else id { let TId s id = $2 in StElse () (getTransSpan $1 s) (Just id) }
-| endif { StEndif () (getSpan $1) Nothing }
-| endif id { let TId s id = $2 in StEndif () (getTransSpan $1 s) (Just id) }
 | do { StDo () (getSpan $1) Nothing Nothing Nothing }
 | id ':' do
   { let TId s id = $1
@@ -501,21 +582,6 @@
 | stop EXPRESSION { StStop () (getTransSpan $1 $2) (Just $2) }
 | pause { StPause () (getSpan $1) Nothing }
 | pause EXPRESSION { StPause () (getTransSpan $1 $2) (Just $2) }
-| selectcase '(' EXPRESSION ')'
-  { StSelectCase () (getTransSpan $1 $4) Nothing $3 }
-| id ':' selectcase '(' EXPRESSION ')'
-  { let TId s id = $1 in StSelectCase () (getTransSpan s $6) (Just id) $5 }
-| case default { StCase () (getTransSpan $1 $2) Nothing Nothing }
-| case default id
-  { let TId s id = $3 in StCase () (getTransSpan $1 s) (Just id) Nothing }
-| case '(' INDICIES ')'
-  { StCase () (getTransSpan $1 $4) Nothing (Just $ fromReverseList $3) }
-| case '(' INDICIES ')' id
-  { let TId s id = $5
-    in StCase () (getTransSpan $1 s) (Just id) (Just $ fromReverseList $3) }
-| endselect { StEndcase () (getSpan $1) Nothing }
-| endselect id
-  { let TId s id = $2 in StEndcase () (getTransSpan $1 s) (Just id) }
 | if '(' EXPRESSION ')' EXECUTABLE_STATEMENT
   { StIfLogical () (getTransSpan $1 $5) $3 $5 }
 | read CILIST IN_IOLIST
@@ -686,21 +752,21 @@
 | INIT_COMMON_GROUP { [ $1 ] }
 
 COMMON_GROUP :: { CommonGroup A0 }
-: COMMON_NAME PART_REFS
+: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST
   { let alist = fromReverseList $2
     in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }
-| '/' '/' PART_REFS
+| '/' '/' UNINITIALIZED_DECLARATOR_LIST
   { let alist = fromReverseList $3
     in CommonGroup () (getTransSpan $1 alist) Nothing alist }
 
 INIT_COMMON_GROUP :: { CommonGroup A0 }
-: COMMON_NAME PART_REFS
+: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST
   { let alist = fromReverseList $2
     in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }
-| '/' '/' PART_REFS
+| '/' '/' UNINITIALIZED_DECLARATOR_LIST
   { let alist = fromReverseList $3
     in CommonGroup () (getTransSpan $1 alist) Nothing alist }
-| PART_REFS
+| UNINITIALIZED_DECLARATOR_LIST
   { let alist = fromReverseList $1
     in CommonGroup () (getSpan alist) Nothing alist }
 
@@ -762,11 +828,11 @@
   { DeclVariable () (getTransSpan $1 $3) $1 Nothing (Just $3) }
 
 DECLARATION_STATEMENT :: { Statement A0 }
-: TYPE_SPEC ATTRIBUTE_LIST '::' DECLARATOR_LIST
+: TYPE_SPEC ATTRIBUTE_LIST '::' INITIALIZED_DECLARATOR_LIST
   { let { mAttrAList = if null $2 then Nothing else Just $ fromReverseList $2;
           declAList = fromReverseList $4 }
     in StDeclaration () (getTransSpan $1 declAList) $1 mAttrAList declAList }
-| TYPE_SPEC DECLARATOR_LIST
+| TYPE_SPEC INITIALIZED_DECLARATOR_LIST
   { let { declAList = fromReverseList $2 }
     in StDeclaration () (getTransSpan $1 declAList) $1 Nothing declAList }
 
@@ -818,11 +884,15 @@
 COMMON_NAME :: { Expression A0 }
 : '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 }
 
-DECLARATOR_LIST :: { [ Declarator A0 ] }
-: DECLARATOR_LIST ',' INITIALISED_DECLARATOR { $3 : $1 }
-| INITIALISED_DECLARATOR { [ $1 ] }
+INITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }
+: INITIALIZED_DECLARATOR_LIST ',' INITIALIZED_DECLARATOR { $3 : $1 }
+| INITIALIZED_DECLARATOR { [ $1 ] }
 
-INITIALISED_DECLARATOR :: { Declarator A0 }
+UNINITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }
+: UNINITIALIZED_DECLARATOR_LIST ',' DECLARATOR { $3 : $1 }
+| DECLARATOR { [ $1 ] }
+
+INITIALIZED_DECLARATOR :: { Declarator A0 }
 : DECLARATOR '=' EXPRESSION { setInitialisation $1 $3 }
 | DECLARATOR '=>' EXPRESSION { setInitialisation $1 $3 }
 | DECLARATOR { $1 }
diff --git a/src/Language/Fortran/Parser/Fortran95.y b/src/Language/Fortran/Parser/Fortran95.y
--- a/src/Language/Fortran/Parser/Fortran95.y
+++ b/src/Language/Fortran/Parser/Fortran95.y
@@ -1,6 +1,7 @@
 -- -*- Mode: Haskell -*-
 {
 module Language.Fortran.Parser.Fortran95 ( functionParser
+                                         , blockParser
                                          , statementParser
                                          , fortran95Parser
                                          , fortran95ParserWithTransforms
@@ -33,6 +34,7 @@
 }
 
 %name programParser PROGRAM
+%name blockParser BLOCK
 %name statementParser STATEMENT
 %name functionParser SUBPROGRAM_UNIT
 %monad { LexAction }
@@ -211,6 +213,10 @@
 
 %%
 
+maybe(p)
+: p           { Just $1 }
+| {- empty -} { Nothing }
+
 -- This rule is to ignore leading whitespace
 PROGRAM :: { ProgramFile A0 }
 : NEWLINE PROGRAM_INNER { $2 }
@@ -310,7 +316,9 @@
 BLOCKS :: { [ Block A0 ] } : BLOCKS BLOCK { $2 : $1 } | {- EMPTY -} { [ ] }
 
 BLOCK :: { Block A0 }
-: INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE
+: IF_BLOCK MAYBE_COMMENT NEWLINE { $1 }
+| CASE_BLOCK MAYBE_COMMENT NEWLINE { $1 }
+| INTEGER_LITERAL STATEMENT MAYBE_COMMENT NEWLINE
   { BlStatement () (getTransSpan $1 $2) (Just $1) $2 }
 | STATEMENT MAYBE_COMMENT NEWLINE { BlStatement () (getSpan $1) Nothing $1 }
 | interface MAYBE_EXPRESSION MAYBE_COMMENT NEWLINE SUBPROGRAM_UNITS2 MODULE_PROCEDURES INTERFACE_END MAYBE_COMMENT NEWLINE
@@ -319,6 +327,93 @@
   { BlInterface () (getTransSpan $1 $8) $2 False [ ] (reverse $5) }
 | COMMENT_BLOCK { $1 }
 
+IF_BLOCK :: { Block A0 }
+IF_BLOCK
+:                        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { startSpan = getSpan $1;
+          (endSpan, conds, blocks, endLabel) = $9;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span Nothing Nothing ((Just $3):conds) ((reverse $8):blocks) endLabel }
+|                 id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { TId startSpan startName = $1;
+          (endSpan, conds, blocks, endLabel) = $11;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span Nothing (Just startName) ((Just $5):conds) ((reverse $10):blocks) endLabel }
+| INTEGER_LITERAL        if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { startSpan = getSpan $1;
+          startLabel = Just $1;
+          (endSpan, conds, blocks, endLabel) = $10;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span startLabel Nothing ((Just $4):conds) ((reverse $9):blocks) endLabel }
+| INTEGER_LITERAL id ':' if '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let { startSpan = getSpan $1;
+          startLabel = Just $1;
+          TId _ startName = $2;
+          (endSpan, conds, blocks, endLabel) = $12;
+          span = getTransSpan startSpan endSpan }
+     in BlIf () span startLabel (Just startName) ((Just $6):conds) ((reverse $11):blocks) endLabel }
+
+ELSE_BLOCKS :: { (SrcSpan, [Maybe (Expression A0)], [[Block A0]], Maybe (Expression A0)) }
+ELSE_BLOCKS
+: maybe(INTEGER_LITERAL) elsif '(' EXPRESSION ')' then MAYBE_COMMENT NEWLINE BLOCKS ELSE_BLOCKS
+  { let (endSpan, conds, blocks, endLabel) = $10
+    in (endSpan, Just $4 : conds, reverse $9 : blocks, endLabel) }
+| maybe(INTEGER_LITERAL) else                          MAYBE_COMMENT NEWLINE BLOCKS END_IF
+  { let (endSpan, endLabel) = $6
+    in (endSpan, [Nothing], [reverse $5], endLabel) }
+| END_IF { let (endSpan, endLabel) = $1 in (endSpan, [], [], endLabel) }
+
+END_IF :: { (SrcSpan, Maybe (Expression A0)) }
+END_IF
+: endif { (getSpan $1, Nothing) }
+| endif id { (getSpan $2, Nothing) }
+| INTEGER_LITERAL endif { (getSpan $2, Just $1) }
+| INTEGER_LITERAL endif id { (getSpan $3, Just $1) }
+
+CASE_BLOCK :: { Block A0 }
+CASE_BLOCK
+:                        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $7;
+          span = getTransSpan $1 endSpan }
+    in BlCase () span Nothing Nothing $3 caseRanges blocks endLabel }
+| INTEGER_LITERAL        selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $8;
+          span = getTransSpan $1 endSpan }
+    in BlCase () span (Just $1) Nothing $4 caseRanges blocks endLabel }
+|                 id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $9;
+          TId s startName = $1;
+          span = getTransSpan s endSpan }
+    in BlCase () span Nothing (Just startName) $5 caseRanges blocks endLabel }
+| INTEGER_LITERAL id ':' selectcase '(' EXPRESSION ')' MAYBE_COMMENT NEWLINE CASES
+  { let { (caseRanges, blocks, endLabel, endSpan) = $10;
+          TId s startName = $2;
+          span = getTransSpan s endSpan }
+    in BlCase () span (Just $1) (Just startName) $6 caseRanges blocks endLabel }
+
+-- We store line comments as statements, but this raises an issue: we have
+-- nowhere to place comments after a SELECT CASE but before a CASE. So we drop
+-- them. The inner CASES_ rule does /not/ use this, because comments can always
+-- be parsed as belonging to to the above CASE block.
+CASES :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }
+: COMMENT_BLOCK CASES_ { $2 }
+|               CASES_ { $1 }
+
+CASES_ :: { ([Maybe (AList Index A0)], [[Block A0]], Maybe (Expression A0), SrcSpan) }
+: maybe(INTEGER_LITERAL) case '(' INDICIES ')' MAYBE_COMMENT NEWLINE BLOCKS CASES_
+  { let (scrutinees, blocks, endLabel, endSpan) = $9
+    in  (Just (fromReverseList $4) : scrutinees, reverse $8 : blocks, endLabel, endSpan) }
+| maybe(INTEGER_LITERAL) case default          MAYBE_COMMENT NEWLINE BLOCKS END_SELECT
+  { let (endLabel, endSpan) = $7
+    in ([Nothing], [$6], endLabel, endSpan) }
+| END_SELECT
+  { let (endLabel, endSpan) = $1
+    in ([], [], endLabel, endSpan) }
+
+END_SELECT :: { (Maybe (Expression A0), SrcSpan) }
+: maybe(INTEGER_LITERAL) endselect maybe(id)
+  { ($1, maybe (getSpan $2) getSpan $3) }
+
 MAYBE_EXPRESSION :: { Maybe (Expression A0) }
 : EXPRESSION { Just $1 }
 | {- EMPTY -} { Nothing }
@@ -379,22 +474,22 @@
   { let saveAList = (fromReverseList $3)
     in StSave () (getTransSpan $1 saveAList) (Just saveAList) }
 | save { StSave () (getSpan $1) Nothing }
-| dimension MAYBE_DCOLON DECLARATOR_LIST
+| dimension MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
   { let declAList = fromReverseList $3
     in StDimension () (getTransSpan $1 declAList) declAList }
-| allocatable MAYBE_DCOLON DECLARATOR_LIST
+| allocatable MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
   { let declAList = fromReverseList $3
     in StAllocatable () (getTransSpan $1 declAList) declAList }
-| pointer MAYBE_DCOLON DECLARATOR_LIST
+| pointer MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
   { let declAList = fromReverseList $3
     in StPointer () (getTransSpan $1 declAList) declAList }
-| target MAYBE_DCOLON DECLARATOR_LIST
+| target MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
   { let declAList = fromReverseList $3
     in StTarget () (getTransSpan $1 declAList) declAList }
-| value MAYBE_DCOLON DECLARATOR_LIST
+| value MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
   { let declAList = fromReverseList $3
     in StValue () (getTransSpan $1 declAList) declAList }
-| volatile MAYBE_DCOLON DECLARATOR_LIST
+| volatile MAYBE_DCOLON INITIALIZED_DECLARATOR_LIST
   { let declAList = fromReverseList $3
     in StVolatile () (getTransSpan $1 declAList) declAList }
 | data cDATA DATA_GROUPS cPOP
@@ -467,16 +562,6 @@
 | endwhere { StEndWhere () (getSpan $1) Nothing }
 | if '(' EXPRESSION ')' INTEGER_LITERAL ',' INTEGER_LITERAL ',' INTEGER_LITERAL
   { StIfArithmetic () (getTransSpan $1 $9) $3 $5 $7 $9 }
-| if '(' EXPRESSION ')' then { StIfThen () (getTransSpan $1 $5) Nothing $3 }
-| id ':' if '(' EXPRESSION ')' then
-  { let TId s id = $1 in StIfThen () (getTransSpan s $7) (Just id) $5 }
-| elsif '(' EXPRESSION ')' then { StElsif () (getTransSpan $1 $5) Nothing $3 }
-| elsif '(' EXPRESSION ')' then id
-  { let TId s id = $6 in StElsif () (getTransSpan $1 s) (Just id) $3 }
-| else { StElse () (getSpan $1) Nothing }
-| else id { let TId s id = $2 in StElse () (getTransSpan $1 s) (Just id) }
-| endif { StEndif () (getSpan $1) Nothing }
-| endif id { let TId s id = $2 in StEndif () (getTransSpan $1 s) (Just id) }
 | do { StDo () (getSpan $1) Nothing Nothing Nothing }
 | id ':' do
   { let TId s id = $1
@@ -509,21 +594,6 @@
 | continue { StContinue () (getSpan $1) }
 | stop { StStop () (getSpan $1) Nothing }
 | stop EXPRESSION { StStop () (getTransSpan $1 $2) (Just $2) }
-| selectcase '(' EXPRESSION ')'
-  { StSelectCase () (getTransSpan $1 $4) Nothing $3 }
-| id ':' selectcase '(' EXPRESSION ')'
-  { let TId s id = $1 in StSelectCase () (getTransSpan s $6) (Just id) $5 }
-| case default { StCase () (getTransSpan $1 $2) Nothing Nothing }
-| case default id
-  { let TId s id = $3 in StCase () (getTransSpan $1 s) (Just id) Nothing }
-| case '(' INDICIES ')'
-  { StCase () (getTransSpan $1 $4) Nothing (Just $ fromReverseList $3) }
-| case '(' INDICIES ')' id
-  { let TId s id = $5
-    in StCase () (getTransSpan $1 s) (Just id) (Just $ fromReverseList $3) }
-| endselect { StEndcase () (getSpan $1) Nothing }
-| endselect id
-  { let TId s id = $2 in StEndcase () (getTransSpan $1 s) (Just id) }
 | if '(' EXPRESSION ')' EXECUTABLE_STATEMENT
   { StIfLogical () (getTransSpan $1 $5) $3 $5 }
 | read CILIST IN_IOLIST
@@ -697,21 +767,21 @@
 | INIT_COMMON_GROUP { [ $1 ] }
 
 COMMON_GROUP :: { CommonGroup A0 }
-: COMMON_NAME PART_REFS
+: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST
   { let alist = fromReverseList $2
     in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }
-| '/' '/' PART_REFS
+| '/' '/' UNINITIALIZED_DECLARATOR_LIST
   { let alist = fromReverseList $3
     in CommonGroup () (getTransSpan $1 alist) Nothing alist }
 
 INIT_COMMON_GROUP :: { CommonGroup A0 }
-: COMMON_NAME PART_REFS
+: COMMON_NAME UNINITIALIZED_DECLARATOR_LIST
   { let alist = fromReverseList $2
     in CommonGroup () (getTransSpan $1 alist) (Just $1) alist }
-| '/' '/' PART_REFS
+| '/' '/' UNINITIALIZED_DECLARATOR_LIST
   { let alist = fromReverseList $3
     in CommonGroup () (getTransSpan $1 alist) Nothing alist }
-| PART_REFS
+| UNINITIALIZED_DECLARATOR_LIST
   { let alist = fromReverseList $1
     in CommonGroup () (getSpan alist) Nothing alist }
 
@@ -773,11 +843,11 @@
   { DeclVariable () (getTransSpan $1 $3) $1 Nothing (Just $3) }
 
 DECLARATION_STATEMENT :: { Statement A0 }
-: TYPE_SPEC ATTRIBUTE_LIST '::' DECLARATOR_LIST
+: TYPE_SPEC ATTRIBUTE_LIST '::' INITIALIZED_DECLARATOR_LIST
   { let { mAttrAList = if null $2 then Nothing else Just $ fromReverseList $2;
           declAList = fromReverseList $4 }
     in StDeclaration () (getTransSpan $1 declAList) $1 mAttrAList declAList }
-| TYPE_SPEC DECLARATOR_LIST
+| TYPE_SPEC INITIALIZED_DECLARATOR_LIST
   { let { declAList = fromReverseList $2 }
     in StDeclaration () (getTransSpan $1 declAList) $1 Nothing declAList }
 
@@ -831,11 +901,15 @@
 COMMON_NAME :: { Expression A0 }
 : '/' VARIABLE '/' { setSpan (getTransSpan $1 $3) $2 }
 
-DECLARATOR_LIST :: { [ Declarator A0 ] }
-: DECLARATOR_LIST ',' INITIALISED_DECLARATOR { $3 : $1 }
-| INITIALISED_DECLARATOR { [ $1 ] }
+INITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }
+: INITIALIZED_DECLARATOR_LIST ',' INITIALIZED_DECLARATOR { $3 : $1 }
+| INITIALIZED_DECLARATOR { [ $1 ] }
 
-INITIALISED_DECLARATOR :: { Declarator A0 }
+UNINITIALIZED_DECLARATOR_LIST :: { [ Declarator A0 ] }
+: UNINITIALIZED_DECLARATOR_LIST ',' DECLARATOR { $3 : $1 }
+| DECLARATOR { [ $1 ] }
+
+INITIALIZED_DECLARATOR :: { Declarator A0 }
 : DECLARATOR '=' EXPRESSION { setInitialisation $1 $3 }
 | DECLARATOR '=>' EXPRESSION { setInitialisation $1 $3 }
 | DECLARATOR { $1 }
diff --git a/src/Language/Fortran/PrettyPrint.hs b/src/Language/Fortran/PrettyPrint.hs
--- a/src/Language/Fortran/PrettyPrint.hs
+++ b/src/Language/Fortran/PrettyPrint.hs
@@ -22,6 +22,18 @@
     featureName ++ " was introduced in " ++ show featureVersion ++
     ". You called pretty print with " ++ show currentVersion ++ "."
 
+-- | Continue only if the given version is equal to or older than a "maximum"
+--   version, or emit a runtime error.
+olderThan :: FortranVersion -> String -> FortranVersion -> a -> a
+olderThan verMax featureName ver cont =
+    if   ver > verMax
+    then error $
+            featureName
+            ++ " is only available in " ++ show verMax
+            ++ " or before. You called pretty print with "
+            ++ show ver ++ "."
+    else cont
+
 (<?>) :: Doc -> Doc -> Doc
 doc1 <?> doc2 = if doc1 == empty || doc2 == empty then empty else doc1 <> doc2
 infixl 7 <?>
@@ -327,6 +339,23 @@
             then indent i (pprint' v label <+> stDoc)
             else pprint' v mLabel `overlay` indent i stDoc
 
+    -- Note that binary expressions such as @a*b@ will always be wrapped in
+    -- brackets. It appears to be built into 'Expression''s 'Pretty' instance.
+    pprint v (BlAssociate _ _ mLabel mName abbrevs bodies mEndLabel) i
+      | v >= Fortran2003 =
+        labeledIndent mLabel
+          $  pprint' v mName <?> colon
+                <+> ("associate" <+> "(" <> pprint' v abbrevs <> ")" <> newline)
+          <> pprint v bodies nextI
+          <> labeledIndent mEndLabel ("end associate" <+> pprint' v mName <> newline)
+      | otherwise = tooOld v "Associate block" Fortran2003
+      where
+        nextI = incIndentation i
+        labeledIndent label stDoc =
+          if v >= Fortran90
+            then indent i (pprint' v label <+> stDoc)
+            else pprint' v mLabel `overlay` indent i stDoc
+
     pprint v (BlComment _ _ (Comment comment)) i
       | v >= Fortran90 = indent i (char '!' <> text comment <> newline)
       | otherwise = char 'c' <> text comment <> newline
@@ -344,6 +373,9 @@
 instance Pretty (e a) => Pretty (AList e a) where
     pprint' v es = commaSep (map (pprint' v) (aStrip es))
 
+instance (Pretty (t1 a), Pretty (t2 a)) => Pretty (ATuple t1 t2 a) where
+    pprint' v (ATuple _ _ t1 t2) = pprint' v t1 <+> "=>" <+> pprint' v t2
+
 instance Pretty BaseType where
     pprint' _ TypeInteger = "integer"
     pprint' _ TypeReal    = "real"
@@ -412,12 +444,13 @@
           pprint' v declList
       | otherwise = error "unhandled version"
 
-    pprint' v (StStructure _ _ mName itemList)
-      | v /= Fortran77Extended = tooOld v "Structure" Fortran77Extended
-      | otherwise =
-          "structure" <> (if isJust mName then " /" <> pprint' v mName <> "/" else empty) <> newline <>
-          foldl' (\doc item -> doc <> pprint v item (incIndentation (Just 0)) <> newline) empty (aStrip itemList) <>
-          "end structure"
+    pprint' v (StStructure _ _ mName itemList) =
+        olderThan Fortran77Legacy "Structure" v $
+          "structure"
+          <+> (if isJust mName then "/" <> pprint' v mName <> "/" else empty)
+          <> newline
+          <> foldl' (\doc item -> doc <> pprint v item (incIndentation (Just 0)) <> newline) empty (aStrip itemList)
+          <> "end structure"
 
     pprint' v (StIntent _ _ intent exps)
       | v >= Fortran90 =
@@ -562,41 +595,6 @@
       pprint' v eqPred <> comma <+>
       pprint' v gtPred
 
-    pprint' v (StIfThen _ _ mConstructor condition)
-      | v >= Fortran90 =
-        pprint' v mConstructor <?> colon <+>
-        "if" <+> parens (pprint' v condition) <+> "then"
-      | v >= Fortran77Extended =
-        case mConstructor of
-          Nothing -> "if" <+> parens (pprint' v condition) <+> "then"
-          _ -> tooOld v "Else" Fortran77Extended
-      | otherwise = tooOld v "Structured if" Fortran90
-
-    pprint' v (StElse _ _ mConstructor)
-      | v >= Fortran90 = "else" <+> pprint' v mConstructor
-      | v >= Fortran77Extended =
-        case mConstructor of
-          Nothing -> "else"
-          Just _ -> tooOld v "Named else" Fortran90
-      | otherwise = tooOld v "Else" Fortran77Extended
-
-    pprint' v (StElsif _ _ mConstructor condition)
-      | v >= Fortran90 =
-        "else if" <+> parens (pprint' v condition) <+> pprint' v mConstructor
-      | v >= Fortran77Extended =
-        case mConstructor of
-          Nothing -> "else if" <+> parens (pprint' v condition)
-          _ -> tooOld v "Named else if" Fortran90
-      | otherwise = tooOld v "Else if" Fortran77Extended
-
-    pprint' v (StEndif _ _ mConstructor)
-      | v >= Fortran90 = "end if" <+> pprint' v mConstructor
-      | v >= Fortran77Extended =
-        case mConstructor of
-          Nothing -> "end if"
-          Just _ -> tooOld v "Named end if" Fortran90
-      | otherwise = tooOld v "End if" Fortran77Extended
-
     pprint' v (StSelectCase _ _ mConstructor exp)
       | v >= Fortran90 =
         pprint' v mConstructor <?> colon <+>
@@ -900,7 +898,7 @@
 
 instance Pretty (CommonGroup a) where
     pprint' v (CommonGroup _ _ mName elems) =
-      char '/' <> pprint' v mName <> char '/' <> pprint' v elems
+      char '/' <> pprint' v mName <> char '/' <+> pprint' v elems
 
 instance Pretty (Namelist a) where
     pprint' Fortran90 (Namelist _ _ name elems) =
diff --git a/src/Language/Fortran/Transformation/Grouping.hs b/src/Language/Fortran/Transformation/Grouping.hs
--- a/src/Language/Fortran/Transformation/Grouping.hs
+++ b/src/Language/Fortran/Transformation/Grouping.hs
@@ -1,8 +1,6 @@
 module Language.Fortran.Transformation.Grouping ( groupForall
-                                                , groupIf
                                                 , groupDo
                                                 , groupLabeledDo
-                                                , groupCase
                                                 ) where
 
 import Language.Fortran.AST
@@ -72,115 +70,7 @@
 isForall (StForallStatement{}) = True
 isForall _ = False
 
---------------------------------------------------------------------------------
--- Grouping if statement blocks into if blocks in entire parse tree
---------------------------------------------------------------------------------
 
-groupIf :: Data a => Transform a ()
-groupIf = genericGroup groupIf' isIf
-
--- Actual grouping is done here.
--- 1. Case: head is a statement block with an IF statement:
--- 1.1  Group everything to the right of the statement.
--- 1.2  Prepend the head
--- 1.3  Decompose into if components (blocks and condition pairs).
--- 1.4  Using original if statement and decomposition artefacts synthesise a
---        structured if block.
--- 1.5  Prepend the block to the left over artefacts, which have already been
---        grouped in 1.1
--- 2. Case: head is a statement block containing any other statement:
--- 2.1  Group everything to the right and prepend the head.
-groupIf' :: ABlocks a -> ABlocks a
-groupIf' [] = []
-groupIf' (b:bs) = b' : bs'
-  where
-    (b', bs') = case b of
-      BlStatement a s label st
-        | StIfThen _ _ mName _ <- st -> -- If statement
-          let ( conditions, blocks, leftOverBlocks, endLabel, endStmt ) =
-                decomposeIf (b:groupedBlocks)
-          in ( BlIf a (getTransSpan s endStmt) label mName conditions blocks endLabel
-             , leftOverBlocks)
-      b'' | containsGroups b'' -> -- Map to subblocks for groupable blocks
-        ( applyGroupingToSubblocks groupIf' b'', groupedBlocks )
-      _ -> ( b, groupedBlocks )
-    groupedBlocks = groupIf' bs -- Assume everything to the right is grouped.
-
--- A program has the following structure:
---
---[ block... ]
--- if <condition> then
---   [ block... ]
--- else if <condition>
---   [ block... ]
--- else
---   [ block... ]
--- end if
--- [ block... ]
---
--- This function must only receive a list of blocks that start with if.
---
--- Internally it uses a more permissive breaking function that processes
--- individual (if-then, block), (else-if, block), and (else, block) pairs.
---
--- In that case it decomposes the block into list of (maybe) conditions and
--- blocks that those conditions correspond to. Additionally, it returns
--- whatever is after the if block.
-decomposeIf :: ABlocks a
-            -> ( [ Maybe (Expression (Analysis a)) ],
-                 [ ABlocks a ],
-                 ABlocks a,
-                 Maybe (Expression (Analysis a)),
-                 Statement (Analysis a) )
-decomposeIf blocks@(BlStatement _ _ _ (StIfThen _ _ mTargetName _):_) =
-    decomposeIf' blocks
-  where
-    decomposeIf' (BlStatement _ _ mLabel st:rest) =
-      case st of
-        StIfThen _ _ _ condition -> go (Just condition) rest
-        StElsif _ _ _ condition -> go (Just condition) rest
-        StElse{} -> go Nothing rest
-        StEndif _ _ mName
-          | mName == mTargetName -> ([], [], rest, mLabel, st)
-          | otherwise -> error $ "If statement name does not match that of " ++
-                                   "the corresponding end if statement."
-        _ -> error "Block with non-if related statement. Should never occur."
-    decomposeIf' _ = error "can't decompose block"
-    go maybeCondition blocks' =
-      let (nonConditionBlocks, rest') = collectNonConditionalBlocks blocks'
-          (conditions, listOfBlocks, rest'', endLabel, endStmt) = decomposeIf' rest'
-      in ( maybeCondition : conditions
-         , nonConditionBlocks : listOfBlocks
-         , rest''
-         , endLabel
-         , endStmt )
-decomposeIf _ = error "can't decompose block"
-
--- This compiles the executable blocks under various if conditions.
-collectNonConditionalBlocks :: ABlocks a -> (ABlocks a, ABlocks a)
-collectNonConditionalBlocks blocks =
-  case blocks of
-    BlStatement _ _ _ StElsif{}:_ -> ([], blocks)
-    BlStatement _ _ _ StElse{}:_ -> ([], blocks)
-    -- Here end block is included within the blocks unlike the other
-    -- conditional directives. The reason is that this block can be
-    -- a branch target if it is labeled according to the specification, hence
-    -- it is presence in the parse tree is meaningful.
-    BlStatement _ _ _ StEndif{}:_ -> ([], blocks)
-    -- Catch all case for all non-if related blocks.
-    b:bs -> let (bs', rest) = collectNonConditionalBlocks bs in (b : bs', rest)
-    -- In this case the structured if block is malformed and the file ends
-    -- prematurely.
-    _ -> error "Premature file ending while parsing structured if block."
-
-isIf :: Statement a -> Bool
-isIf s = case s of
-  StIfThen{} -> True
-  StElsif{}  -> True
-  StElse{}   -> True
-  StEndif{}  -> True
-  _          -> False
-
 --------------------------------------------------------------------------------
 -- Grouping new do statement blocks into do blocks in entire parse tree
 --------------------------------------------------------------------------------
@@ -296,74 +186,6 @@
   _                         -> False
 
 --------------------------------------------------------------------------------
--- Grouping case statements
---------------------------------------------------------------------------------
-
-groupCase :: Data a => Transform a ()
-groupCase = genericGroup groupCase' isCase
-
-groupCase' :: ABlocks a -> ABlocks a
-groupCase' [] = []
-groupCase' (b:bs) = b' : bs'
-  where
-    (b', bs') = case b of
-      BlStatement a s label st
-        | StSelectCase _ _ mName scrutinee <- st ->
-          let blocksToDecomp = dropWhile isComment groupedBlocks
-              ( conds, blocks, leftOverBlocks, endLabel ) = decomposeCase blocksToDecomp mName
-          in ( BlCase a (getTransSpan s blocks) label mName scrutinee conds blocks endLabel
-             , leftOverBlocks)
-      b'' | containsGroups b'' -> -- Map to subblocks for groupable blocks
-        ( applyGroupingToSubblocks groupCase' b'', groupedBlocks )
-      _ -> ( b , groupedBlocks )
-    groupedBlocks = groupCase' bs -- Assume everything to the right is grouped.
-    isComment b'' = case b'' of { BlComment{} -> True; _ -> False }
-
-decomposeCase :: ABlocks a -> Maybe String
-              -> ( [ Maybe (AList Index (Analysis a)) ]
-                 , [ ABlocks a ]
-                 , ABlocks a
-                 , Maybe (Expression (Analysis a)) )
-decomposeCase (BlStatement _ _ mLabel st:rest) mTargetName =
-    case st of
-      StCase _ _ mName mCondition
-        | Nothing <- mName -> go mCondition rest
-        | mName == mTargetName -> go mCondition rest
-        | otherwise -> error $ "Case name does not match that of " ++
-                                 "the corresponding select case statement."
-      StEndcase _ _ mName
-        | mName == mTargetName -> ([], [], rest, mLabel)
-        | otherwise -> error $ "End case name does not match that of " ++
-                                 "the corresponding select case statement."
-      _ -> error "Block with non-case related statement. Must not occur."
-  where
-    go mCondition blocks =
-      let (nonCaseBlocks, rest') = collectNonCaseBlocks blocks
-          (conditions, listOfBlocks, rest'', endLabel) = decomposeCase rest' mTargetName
-      in ( mCondition : conditions
-         , nonCaseBlocks : listOfBlocks
-         , rest'', endLabel )
-decomposeCase _ _ = error "can't decompose case"
-
--- This compiles the executable blocks under various if conditions.
-collectNonCaseBlocks :: ABlocks a -> (ABlocks a, ABlocks a)
-collectNonCaseBlocks blocks =
-  case blocks of
-    BlStatement _ _ _ st:_
-      | StCase{} <- st -> ( [], blocks )
-      | StEndcase{} <- st -> ( [], blocks )
-    -- In this case case block is malformed and the file ends prematurely.
-    b:bs -> let (bs', rest) = collectNonCaseBlocks bs in (b : bs', rest)
-    _ -> error "Premature file ending while parsing select case block."
-
-isCase :: Statement a -> Bool
-isCase s = case s of
-  StCase{}       -> True
-  StEndcase{}    -> True
-  StSelectCase{} -> True
-  _              -> False
-
---------------------------------------------------------------------------------
 -- Helpers for grouping of structured blocks with more blocks inside.
 --------------------------------------------------------------------------------
 
@@ -371,29 +193,35 @@
 containsGroups b =
   case b of
     BlStatement{} -> False
-    BlIf{} -> True
-    BlCase{} -> True
-    BlDo{} -> True
-    BlDoWhile{} -> True
+    BlIf{}        -> True
+    BlCase{}      -> True
+    BlDo{}        -> True
+    BlDoWhile{}   -> True
     BlInterface{} -> False
-    BlComment{} -> False
-    BlForall{}  -> True
+    BlComment{}   -> False
+    BlForall{}    -> True
+    BlAssociate{} -> True
 
 applyGroupingToSubblocks :: (ABlocks a -> ABlocks a) -> Block (Analysis a) -> Block (Analysis a)
 applyGroupingToSubblocks f b
   | BlStatement{} <- b =
       error "Individual statements do not have subblocks. Must not occur."
-  | BlIf a s l mn conds blocks el <- b = BlIf a s l mn conds (map f blocks) el
-  | BlCase a s l mn scrutinee conds blocks el <- b =
-      BlCase a s l mn scrutinee conds (map f blocks) el
-  | BlDo a s l n tl doSpec blocks el <- b = BlDo a s l n tl doSpec (f blocks) el
-  | BlDoWhile a s l n tl doSpec blocks el <- b = BlDoWhile a s l n tl doSpec (f blocks) el
+  | BlIf a s l mn conds blocks         el <- b =
+    BlIf a s l mn conds (map f blocks) el
+  | BlCase a s l mn scrutinee conds blocks         el <- b =
+    BlCase a s l mn scrutinee conds (map f blocks) el
+  | BlDo a s l n tl doSpec blocks     el <- b =
+    BlDo a s l n tl doSpec (f blocks) el
+  | BlDoWhile a s l n tl doSpec blocks     el <- b =
+    BlDoWhile a s l n tl doSpec (f blocks) el
   | BlInterface{} <- b =
       error "Interface blocks do not have groupable subblocks. Must not occur."
   | BlComment{} <- b =
       error "Comment statements do not have subblocks. Must not occur."
   | BlForall a s ml mn h blocks mel <- b =
-     BlForall a s ml mn h (f blocks) mel
+    BlForall a s ml mn h (f blocks) mel
+  | BlAssociate a s ml mn abbrevs blocks     mel <- b =
+    BlAssociate a s ml mn abbrevs (f blocks) mel
 
 --------------------------------------------------
 
diff --git a/src/Language/Fortran/Transformer.hs b/src/Language/Fortran/Transformer.hs
--- a/src/Language/Fortran/Transformer.hs
+++ b/src/Language/Fortran/Transformer.hs
@@ -20,8 +20,6 @@
 
 data Transformation =
     GroupForall
-  | GroupIf
-  | GroupCase
   | GroupDo
   | GroupLabeledDo
   | DisambiguateFunction
@@ -31,8 +29,6 @@
 transformationMapping :: Data a => Transformation -> Transform a ()
 transformationMapping = \case
   GroupForall           -> groupForall
-  GroupIf               -> groupIf
-  GroupCase             -> groupCase
   GroupDo               -> groupDo
   GroupLabeledDo        -> groupLabeledDo
   DisambiguateFunction  -> disambiguateFunction
@@ -49,6 +45,10 @@
     trans = mapM_ transformationMapping trs
 
 -- | The default post-parse AST transformations for each Fortran version.
+--
+-- Note that some of these may not be commutative with each other. Specifically,
+-- the DO groupings are written so labeled (nonblock) DO grouping must occur
+-- first, followed by block DO grouping.
 defaultTransformations :: FortranVersion -> [Transformation]
 defaultTransformations = \case
   Fortran66 ->
@@ -56,9 +56,14 @@
     , DisambiguateIntrinsic
     , DisambiguateFunction
     ]
-  Fortran77         -> GroupIf   : defaultTransformations Fortran66
-  Fortran77Legacy   -> GroupDo   : defaultTransformations Fortran77
-  Fortran77Extended -> GroupCase : defaultTransformations Fortran77Legacy
+  Fortran77         -> defaultTransformations Fortran66
+  Fortran77Legacy   ->
+    [ GroupLabeledDo
+    , GroupDo
+    , DisambiguateIntrinsic
+    , DisambiguateFunction
+    ]
+  Fortran77Extended -> defaultTransformations Fortran77Legacy
   Fortran90   -> defaultTransformations Fortran77Extended
   Fortran95   -> defaultTransformations Fortran77Extended
   Fortran2003 -> defaultTransformations Fortran77Extended
diff --git a/src/Language/Fortran/Version.hs b/src/Language/Fortran/Version.hs
--- a/src/Language/Fortran/Version.hs
+++ b/src/Language/Fortran/Version.hs
@@ -19,6 +19,10 @@
 import Control.DeepSeq (NFData)
 import Text.PrettyPrint.GenericPretty (Out)
 
+-- | The Fortran specification version used (or relevant to its context).
+--
+-- The constructor ordering is important, since it's used for the Ord instance
+-- (which is used extensively for pretty printing).
 data FortranVersion = Fortran66
                     | Fortran77
                     | Fortran77Extended
diff --git a/src/Main.hs b/src/Main.hs
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -330,7 +330,7 @@
 showTypes tenv =
     flip concatMap (M.toList tenv) $
       \ (name, IDType { idVType = vt, idCType = ct }) ->
-        printf "%s\t\t%s %s\n" name (drop 3 $ maybe "  -" show vt) (drop 2 $ maybe "   " show ct)
+        printf "%s\t\t%s %s\n" name (drop 1 $ maybe "  -" show vt) (drop 2 $ maybe "   " show ct)
 printTypes :: TypeEnv -> IO ()
 printTypes = putStrLn . showTypes
 showTypeErrors :: [TypeError] -> String
diff --git a/test/Language/Fortran/Analysis/TypesSpec.hs b/test/Language/Fortran/Analysis/TypesSpec.hs
--- a/test/Language/Fortran/Analysis/TypesSpec.hs
+++ b/test/Language/Fortran/Analysis/TypesSpec.hs
@@ -12,6 +12,7 @@
 import Language.Fortran.Analysis.Types
 import Language.Fortran.Analysis.SemanticTypes
 import Language.Fortran.Analysis.Renaming
+import qualified Language.Fortran.Parser.Fortran77 as F77
 import qualified Language.Fortran.Parser.Fortran90 as F90
 import Language.Fortran.ParserMonad
 import qualified Data.ByteString.Char8 as B
@@ -22,6 +23,9 @@
 typedProgramFile :: Data a => ProgramFile a -> ProgramFile (Analysis a)
 typedProgramFile = fst . analyseTypes . analyseRenames . initAnalysis
 
+legacy77Parser :: String -> String -> ProgramFile A0
+legacy77Parser src file = fromParseResultUnsafe $ F77.legacy77Parser (B.pack src) file
+
 fortran90Parser :: String -> String -> ProgramFile A0
 fortran90Parser src file = fromParseResultUnsafe $ F90.fortran90Parser (B.pack src) file
 
@@ -148,6 +152,29 @@
                                         (Just (CTArray [(Nothing, Just 20)])))]
           `shouldNotSatisfy` null
 
+    describe "structs and arrays" $ do
+      it "can handle typing assignments to arrays within structs" $ do
+        let mapping = inferTable $ structArray False
+        mapping ! "s" `shouldBe` IDType (Just $ TCustom "strut") (Just CTVariable)
+      it "can handle typing assignments to elements in arrays of structs" $ do
+        let mapping = inferTable $ arrayOfStructs False
+        mapping ! "a" `shouldBe` IDType (Just $ TCustom "elem") (Just $ CTArray [(Nothing, Just 10)])
+      it "can handle typing assignments to array elements in arrays of structs" $ do
+        let mapping = inferTable $ arrayOfStructsWithArrays False
+        mapping ! "arr" `shouldBe` IDType (Just $ TCustom "elem2") (Just $ CTArray [(Nothing, Just 10)])
+
+    describe "structs and arrays in common area" $ do
+      it "can handle typing assignments to arrays within structs in common area" $ do
+        let mapping = inferTable $ structArray True
+        mapping ! "s" `shouldBe` IDType (Just $ TCustom "strut") (Just CTVariable)
+      it "can handle typing assignments to elements in arrays of structs in common area" $ do
+        let mapping = inferTable $ arrayOfStructs True
+        mapping ! "a" `shouldBe` IDType (Just $ TCustom "elem") (Just $ CTArray [(Nothing, Just 10)])
+      it "can handle typing assignments to array elements in arrays of structs in common area" $ do
+        let mapping = inferTable $ arrayOfStructsWithArrays True
+        mapping ! "arr" `shouldBe` IDType (Just $ TCustom "elem2") (Just $ CTArray [(Nothing, Just 10)])
+
+
 ex1 :: ProgramFile ()
 ex1 = ProgramFile mi77 [ ex1pu1 ]
 ex1pu1 :: ProgramUnit ()
@@ -305,6 +332,66 @@
   , "  character(kind=2) :: f"
   , "end program teststrings"
   ]
+
+commonTransform :: [String] -> String -> [String] -> Bool -> ProgramFile A0
+commonTransform front cdecl back common =
+  resetSrcSpan . flip legacy77Parser "" . unlines . (++) front $
+    if common then cdecl : back else back
+
+structArray :: Bool -> ProgramFile A0
+structArray = commonTransform front cdecl back
+  where
+    front = [
+        "      subroutine totes"
+      , "       structure /strut/"
+      , "         integer*4 arr(10)"
+      , "       end structure"
+      , "       record /strut/ s"
+      ]
+    cdecl =
+        "       common /comm/ s"
+    back = [
+        "       s.arr(7) = 345"
+      , "       print *, 'eyo'"
+      , "      end subroutine totes"
+      ]
+
+arrayOfStructs :: Bool -> ProgramFile A0
+arrayOfStructs = commonTransform front cdecl back
+  where
+    front = [
+        "      subroutine totes"
+      , "       structure /elem/"
+      , "         integer val"
+      , "       end structure"
+      , "       record /elem/ a(10)"
+      ]
+    cdecl =
+        "       common /comm2/ a"
+    back = [
+        "       a(7).val = 345"
+      , "       print *, 'done'"
+      , "      end subroutine totes"
+      ]
+
+arrayOfStructsWithArrays :: Bool -> ProgramFile A0
+arrayOfStructsWithArrays = commonTransform front cdecl back
+  where
+    front = [
+        "      subroutine totes"
+      , "       structure /elem2/"
+      , "         integer vals(4)"
+      , "       end structure"
+      , "       record /elem2/ arr(10)"
+      ]
+    cdecl =
+        "       common /comm3/ arr"
+    back = [
+        "       arr(7).vals(2) = 45"
+      , "       print *, 'DONE'"
+      , "      end subroutine totes"
+      ]
+
 
 -- Local variables:
 -- mode: haskell
diff --git a/test/Language/Fortran/Parser/Fortran2003Spec.hs b/test/Language/Fortran/Parser/Fortran2003Spec.hs
--- a/test/Language/Fortran/Parser/Fortran2003Spec.hs
+++ b/test/Language/Fortran/Parser/Fortran2003Spec.hs
@@ -21,14 +21,19 @@
     paddedSourceCode = B.pack $ "      a = " ++ sourceCode
     parseState =  initParseState paddedSourceCode Fortran2003 "<unknown>"
 
+simpleParser :: Parse AlexInput Token a -> String -> a
+simpleParser p sourceCode =
+  evalParse p $ initParseState (B.pack sourceCode) Fortran2003 "<unknown>"
+
 sParser :: String -> Statement ()
-sParser sourceCode =
-  evalParse statementParser $ initParseState (B.pack sourceCode) Fortran2003 "<unknown>"
+sParser = simpleParser statementParser
 
 fParser :: String -> ProgramUnit ()
-fParser sourceCode =
-  evalParse functionParser $ initParseState (B.pack sourceCode) Fortran2003 "<unknown>"
+fParser = simpleParser functionParser
 
+bParser :: String -> Block ()
+bParser = simpleParser blockParser
+
 spec :: Spec
 spec =
   describe "Fortran 2003 Parser" $ do
@@ -141,16 +146,32 @@
         sParser "real, protected, public :: x" `shouldBe'` st1
         sParser "protected x" `shouldBe'` st2
 
-      describe "labelled where" $ do
-        it "parses where construct statement" $
-          sParser "foo: where (.true.)" `shouldBe'` StWhereConstruct () u (Just "foo") valTrue
+    describe "labelled where" $ do
+      it "parses where construct statement" $
+        sParser "foo: where (.true.)" `shouldBe'` StWhereConstruct () u (Just "foo") valTrue
 
-        it "parses elsewhere statement" $
-          sParser "elsewhere ab101" `shouldBe'` StElsewhere () u (Just "ab101") Nothing
+      it "parses elsewhere statement" $
+        sParser "elsewhere ab101" `shouldBe'` StElsewhere () u (Just "ab101") Nothing
 
-        it "parses elsewhere statement" $ do
-          let exp = ExpBinary () u GT (varGen "a") (varGen "b")
-          sParser "elsewhere (a > b) A123" `shouldBe'` StElsewhere () u (Just "a123") (Just exp)
+      it "parses elsewhere statement" $ do
+        let exp = ExpBinary () u GT (varGen "a") (varGen "b")
+        sParser "elsewhere (a > b) A123" `shouldBe'` StElsewhere () u (Just "a123") (Just exp)
 
-        it "parses endwhere statement" $
-          sParser "endwhere foo1" `shouldBe'` StEndWhere () u (Just "foo1")
+      it "parses endwhere statement" $
+        sParser "endwhere foo1" `shouldBe'` StEndWhere () u (Just "foo1")
+
+    describe "associate block" $ do
+      it "parses multiple assignment associate block" $ do
+        let text = unlines [ "associate (x => a, y => (a * b))"
+                           , "  print *, x"
+                           , "  print *, y"
+                           , "end associate" ]
+            expected = BlAssociate () u Nothing Nothing abbrevs body' Nothing
+            body'   = [blStmtPrint "x", blStmtPrint "y"]
+            blStmtPrint x = BlStatement () u Nothing (stmtPrint x)
+            stmtPrint x = StPrint () u starVal (Just $ AList () u [ varGen x ])
+            abbrevs = AList () u [abbrev "x" (expValVar "a"), abbrev "y" (expBinVars Multiplication "a" "b")]
+            abbrev var expr = ATuple () u (expValVar var) expr
+            expValVar x = ExpValue () u (ValVariable x)
+            expBinVars op x1 x2 = ExpBinary () u op (expValVar x1) (expValVar x2)
+        bParser text `shouldBe'` expected
diff --git a/test/Language/Fortran/Parser/Fortran66Spec.hs b/test/Language/Fortran/Parser/Fortran66Spec.hs
--- a/test/Language/Fortran/Parser/Fortran66Spec.hs
+++ b/test/Language/Fortran/Parser/Fortran66Spec.hs
@@ -110,13 +110,13 @@
         sParser "      EXTERNAL f, g, h" `shouldBe'` expectedSt
 
       it "parses 'COMMON a, b'" $ do
-        let comGr = CommonGroup () u Nothing (AList () u [ varGen "a", varGen "b" ])
+        let comGr = CommonGroup () u Nothing (AList () u [ declVarGen "a", declVarGen "b" ])
         let st = StCommon () u (AList () u [ comGr ])
         sParser "      COMMON a, b" `shouldBe'` st
 
       it "parses 'COMMON // a, b /hello/ x, y, z'" $ do
-        let comGrs = [ CommonGroup () u Nothing (AList () u [ varGen "a", varGen "b" ])
-                     , CommonGroup () u (Just $ varGen "hello") (AList () u [ varGen "x", varGen "y", varGen "z" ]) ]
+        let comGrs = [ CommonGroup () u Nothing (AList () u [ declVarGen "a", declVarGen "b" ])
+                     , CommonGroup () u (Just $ varGen "hello") (AList () u [ declVarGen "x", declVarGen "y", declVarGen "z" ]) ]
         let st = StCommon () u (AList () u comGrs)
         sParser "      COMMON // a, b /hello/ x, y, z" `shouldBe'` st
 
diff --git a/test/Language/Fortran/Parser/Fortran77/IncludeSpec.hs b/test/Language/Fortran/Parser/Fortran77/IncludeSpec.hs
--- a/test/Language/Fortran/Parser/Fortran77/IncludeSpec.hs
+++ b/test/Language/Fortran/Parser/Fortran77/IncludeSpec.hs
@@ -1,5 +1,6 @@
 module Language.Fortran.Parser.Fortran77.IncludeSpec where
 
+import System.FilePath
 import Test.Hspec
 import TestUtil
 
@@ -23,7 +24,7 @@
                           "      include 'foo.f'",
                           "      end"
                          ]
-        incs = ["./test/Language/Fortran/Parser"]
+        inc = "./test/Language/Fortran/Parser"
         name = "bar"
         pf = ProgramFile mi77 [pu]
         puSpan = makeSrcR (6,7,1,"<unknown>") (48,9,3,"<unknown>")
@@ -32,10 +33,11 @@
 
         -- the expansion returns the span in the included file
         -- it should return the span at the inclusion
-        st2Span = makeSrcR (6,7,1,"foo.f") (14,15,1,"foo.f")
-        declSpan = makeSrcR (6,7,1,"foo.f") (14,15,1,"foo.f")
-        typeSpan = makeSrcR (6,7,1,"foo.f") (12,13,1,"foo.f")
-        blockSpan = makeSrcR (14,15,1,"foo.f") (14,15,1,"foo.f")
+        foo = inc </> "foo.f"
+        st2Span = makeSrcR (6,7,1, foo) (14,15,1,foo)
+        declSpan = makeSrcR (6,7,1,foo) (14,15,1,foo)
+        typeSpan = makeSrcR (6,7,1,foo) (12,13,1,foo)
+        blockSpan = makeSrcR (14,15,1,foo) (14,15,1,foo)
         varGen' str =  ExpValue () blockSpan $ ValVariable str
 
         pu = PUMain () puSpan (Just name) blocks Nothing
@@ -48,6 +50,6 @@
         ex = ExpValue () expSpan (ValString "foo.f")
         bl2 = BlStatement () declSpan Nothing st2
     it "includes some files and expands them" $ do
-      ps <- iParser incs source
+      ps <- iParser [inc] source
       let pr = fromParseResultUnsafe ps
       pr `shouldBe` pf
diff --git a/test/Language/Fortran/Parser/Fortran77/ParserSpec.hs b/test/Language/Fortran/Parser/Fortran77/ParserSpec.hs
--- a/test/Language/Fortran/Parser/Fortran77/ParserSpec.hs
+++ b/test/Language/Fortran/Parser/Fortran77/ParserSpec.hs
@@ -29,6 +29,9 @@
 slParser sourceCode =
   evalParse statementParser $ initParseState (B.pack sourceCode) Fortran77Legacy "<unknown>"
 
+blParser :: String -> Block ()
+blParser src = evalParse blockParser $ initParseState (B.pack src) Fortran77Legacy "<unknown>"
+
 iParser :: String -> [Block ()]
 iParser sourceCode =
   fromParseResultUnsafe $ includeParser Fortran77Legacy (B.pack sourceCode) "<unknown>"
@@ -220,6 +223,31 @@
           st = StDeclaration () u typeSpec Nothing (AList () u [ decl ])
           bl = BlStatement () u Nothing st
       iParser "      integer a" `shouldBe'` [bl]
+
+    describe "parses if blocks" $ do
+      let printArgs  = Just $ AList () u [ExpValue () u $ ValString "foo"]
+          printStmt  = StPrint () u (ExpValue () u ValStar) printArgs
+          printBlock = BlStatement () u Nothing printStmt
+          trueLit = ExpValue () u $ ValLogical ".true."
+      it "unlabelled" $ do
+        let bl = BlIf () u Nothing Nothing [ Just trueLit, Nothing ] [[printBlock], [printBlock]]  Nothing
+            src = unlines [ "      if (.true.) then ! comment if"
+                          , "        print *, 'foo'"
+                          , "      else ! comment else"
+                          , "        print *, 'foo'"
+                          , "       endif ! comment end"
+                          ]
+        blParser src `shouldBe'` bl
+      it "labelled" $ do
+        let label str = Just $ ExpValue () u $ ValInteger str
+            bl = BlIf () u (label "10")  Nothing [Just trueLit, Nothing] [[printBlock], [printBlock]] (label "30")
+            src = unlines [ "10    if (.true.) then ! comment if"
+                          , "        print *, 'foo'"
+                          , "20    else ! comment else"
+                          , "        print *, 'foo'"
+                          , "30     endif ! comment end"
+                          ]
+        blParser src `shouldBe'` bl
 
     describe "Legacy Extensions" $ do
       it "parses structure/union/map blocks" $ do
diff --git a/test/Language/Fortran/Parser/Fortran90Spec.hs b/test/Language/Fortran/Parser/Fortran90Spec.hs
--- a/test/Language/Fortran/Parser/Fortran90Spec.hs
+++ b/test/Language/Fortran/Parser/Fortran90Spec.hs
@@ -27,6 +27,10 @@
 sParser sourceCode =
   evalParse statementParser $ initParseState (B.pack sourceCode) Fortran90 "<unknown>"
 
+blParser :: String -> Block ()
+blParser sourceCode =
+  evalParse blockParser $ initParseState (B.pack sourceCode) Fortran90 "<unknown>"
+
 fParser :: String -> ProgramUnit ()
 fParser sourceCode =
   evalParse functionParser $ initParseState (B.pack sourceCode) Fortran95 "<unknown>"
@@ -350,10 +354,10 @@
       describe "Common" $ do
         let commonNames = [ ExpValue () u (ValVariable "something")
                           , ExpValue () u (ValVariable "other") ]
-        let itemss = [ fromList () [ varGen "a", varGen "b", varGen "c" ]
-                     , fromList () [ varGen "y" ] ]
+        let itemss = [ fromList () [ declVarGen "a", declVarGen "b", declVarGen "c" ]
+                     , fromList () [ declVarGen "y" ] ]
         let st = StCommon () u $ fromList ()
-              [ CommonGroup () u Nothing (fromList () [ varGen "q" ])
+              [ CommonGroup () u Nothing (fromList () [ declVarGen "q" ])
               , CommonGroup () u (Just $ head commonNames) (head itemss)
               , CommonGroup () u (Just $ last commonNames) (last itemss) ]
 
@@ -435,21 +439,22 @@
             sParser "endwhere" `shouldBe'` StEndWhere () u Nothing
 
     describe "If" $ do
-      it "parses if-then statement" $
-        sParser "if (.false.) then" `shouldBe'` StIfThen () u Nothing valFalse
-
-      it "parses if-then statement with construct name" $ do
-        let st = StIfThen () u (Just "my_if") valFalse
-        sParser "my_if: if (.false.) then" `shouldBe'` st
-
-      it "parses else statement" $
-        sParser "else" `shouldBe'` StElse () u Nothing
+      let stPrint = StPrint () u starVal (Just $ fromList () [ ExpValue () u (ValString "foo")])
+      it "parser if block" $
+        let ifBlockSrc = unlines [ "if (.false.) then", "print *, 'foo'", "end if"]
+            falseLit = ExpValue () u (ValLogical ".false.")
+        in blParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just falseLit] [[BlStatement () u Nothing stPrint]] Nothing
 
-      it "parses else-if statement" $
-        sParser "else if (.true.) then" `shouldBe'` StElsif () u Nothing valTrue
+      it "parses named if block" $ do
+        let ifBlockSrc = unlines [ "mylabel : if (.true.) then", "print *, 'foo'", "end if mylabel"]
+            trueLit = ExpValue () u (ValLogical ".true.")
+            ifBlock = BlIf () u Nothing (Just "mylabel") [Just trueLit] [[BlStatement () u Nothing stPrint]] Nothing
+        blParser ifBlockSrc `shouldBe'` ifBlock
 
-      it "parses end if statement" $
-        sParser "end if" `shouldBe'` StEndif () u Nothing
+      it "parses if-else block with inline comments (stripped)" $
+        let ifBlockSrc = unlines [ "if (.false.) then ! comment if", "print *, 'foo'", "else ! comment else", "print *, 'foo'", "end if ! comment end"]
+            falseLit = ExpValue () u (ValLogical ".false.")
+        in blParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just falseLit, Nothing] [[BlStatement () u Nothing stPrint], [BlStatement () u Nothing stPrint]] Nothing
 
       it "parses logical if statement" $ do
         let assignment = StExpressionAssign () u (varGen "a") (varGen "b")
@@ -463,24 +468,45 @@
         sParser "if (x) 1, 2, 3" `shouldBe'` stIf
 
     describe "Case" $ do
-      it "parses select case statement" $ do
-        let st = StSelectCase () u Nothing (varGen "n")
-        sParser "select case (n)" `shouldBe'` st
-
-      it "parses select case statement with construct name" $ do
-        let st = StSelectCase () u (Just "case") (varGen "n")
-        sParser "case: select case (n)" `shouldBe'` st
-
-      it "parses case statement" $ do
-        let ranges = AList () u [ IxRange () u (Just $ intGen 42) Nothing Nothing ]
-        sParser "case (42:)" `shouldBe'` StCase () u Nothing (Just ranges)
-
-      it "parses case statement" $
-        sParser "case default" `shouldBe'` StCase () u Nothing Nothing
-
-      it "parses end select statement" $ do
-        let st = StEndcase () u (Just "name")
-        sParser "end select name" `shouldBe'` st
+      let printArgs str = Just $ AList () u [ExpValue () u $ ValString str]
+          printStmt = StPrint () u (ExpValue () u ValStar) . printArgs
+          printBlock = BlStatement () u Nothing . printStmt
+          intLit = ExpValue () u . ValInteger
+          ind2 = AList () u . pure $ IxSingle () u Nothing $ intLit "2"
+          ind3Plus = AList () u . pure $ IxRange () u (Just $ intLit "3") Nothing Nothing
+          conds = [Just ind2, Just ind3Plus, Nothing]
+      it "unlabelled case block (with inline comments to be stripped)" $ do
+        let src = unlines [ "select case (x) ! inline select"
+                          , "! full line before first case (unrepresentable)"
+                          , "case (2) ! inline case 1"
+                          , "print *, 'foo'"
+                          , "case (3:) ! inline case 2"
+                          , "print *, 'bar'"
+                          , "case default ! inline case 3"
+                          , "print *, 'baz'"
+                          , "end select ! inline end"
+                          ]
+            blocks = (fmap . fmap) printBlock [["foo"], ["bar"], ["baz"]]
+            block = BlCase () u Nothing Nothing (varGen "x") conds blocks Nothing
+        blParser src `shouldBe'` block
+      it "labelled case block (with inline comments to be stripped" $ do
+        let src = unlines [ "10 mylabel: select case (x) ! comment select"
+                          , "20 case (2) ! inline case 1"
+                          , "30 print *, 'foo'"
+                          , "40 case (3:) ! inline case 2"
+                          , "50 print *, 'bar'"
+                          , "60 case default ! inline case 3"
+                          , "70 print *, 'baz'"
+                          , "80 end select mylabel ! inline end"
+                          ]
+            blocks = (fmap . fmap)
+                     (\(label, arg) -> BlStatement () u (Just $ intLit label) $ printStmt arg)
+                     [[("30", "foo")], [("50", "bar")], [("70", "baz")]]
+            block = BlCase () u
+                           (Just $ intLit "10") (Just "mylabel") (varGen "x")
+                           conds blocks
+                           (Just $ intLit "80")
+        blParser src `shouldBe'` block
 
     describe "Do" $ do
       it "parses do statement with label" $ do
@@ -503,9 +529,18 @@
         let st = StEnddo () u (Just "constructor")
         sParser "end do constructor" `shouldBe'` st
 
-      it "parses end do while statement" $ do
+    describe "DO WHILE" $ do
+      it "parses unnamed do while statement" $ do
+        let st = StDoWhile () u Nothing Nothing valTrue
+        sParser "do while (.true.)" `shouldBe'` st
+
+      it "parses named do while statement" $ do
         let st = StDoWhile () u (Just "name") Nothing valTrue
         sParser "name: do while (.true.)" `shouldBe'` st
+
+      it "parses unnamed labelled do while statement" $ do
+        let st = StDoWhile () u Nothing (Just (intGen 999)) valTrue
+        sParser "do 999 while (.true.)" `shouldBe'` st
 
     describe "Goto" $ do
       it "parses vanilla goto" $ do
diff --git a/test/Language/Fortran/Parser/Fortran95Spec.hs b/test/Language/Fortran/Parser/Fortran95Spec.hs
--- a/test/Language/Fortran/Parser/Fortran95Spec.hs
+++ b/test/Language/Fortran/Parser/Fortran95Spec.hs
@@ -29,6 +29,10 @@
 sParser sourceCode =
   evalParse statementParser $ initParseState (B.pack sourceCode) Fortran95 "<unknown>"
 
+blParser :: String -> Block ()
+blParser sourceCode =
+  evalParse blockParser $ initParseState (B.pack sourceCode) Fortran95 "<unknown>"
+
 fParser :: String -> ProgramUnit ()
 fParser sourceCode =
   evalParse functionParser $ initParseState (B.pack sourceCode) Fortran95 "<unknown>"
@@ -402,10 +406,10 @@
       describe "Common" $ do
         let commonNames = [ ExpValue () u (ValVariable "something")
                           , ExpValue () u (ValVariable "other") ]
-            itemss = [ fromList () [ varGen "a", varGen "b", varGen "c" ]
-                     , fromList () [ varGen "y" ] ]
+            itemss = [ fromList () [ declVarGen "a", declVarGen "b", declVarGen "c" ]
+                     , fromList () [ declVarGen "y" ] ]
             st = StCommon () u $ fromList ()
-              [ CommonGroup () u Nothing (fromList () [ varGen "q" ])
+              [ CommonGroup () u Nothing (fromList () [ declVarGen "q" ])
               , CommonGroup () u (Just $ head commonNames) (head itemss)
               , CommonGroup () u (Just $ last commonNames) (last itemss) ]
 
@@ -484,21 +488,22 @@
             sParser "endwhere" `shouldBe'` StEndWhere () u Nothing
 
     describe "If" $ do
-      it "parses if-then statement" $
-        sParser "if (.false.) then" `shouldBe'` StIfThen () u Nothing valFalse
-
-      it "parses if-then statement with construct name" $ do
-        let st = StIfThen () u (Just "my_if") valFalse
-        sParser "my_if: if (.false.) then" `shouldBe'` st
-
-      it "parses else statement" $
-        sParser "else" `shouldBe'` StElse () u Nothing
+      let stPrint = StPrint () u starVal (Just $ fromList () [ ExpValue () u (ValString "foo")])
+      it "parser if block" $
+        let ifBlockSrc = unlines [ "if (.false.) then", "print *, 'foo'", "end if"]
+            falseLit = ExpValue () u (ValLogical ".false.")
+        in blParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just falseLit] [[BlStatement () u Nothing stPrint]] Nothing
 
-      it "parses else-if statement" $
-        sParser "else if (.true.) then" `shouldBe'` StElsif () u Nothing valTrue
+      it "parses named if block" $ do
+        let ifBlockSrc = unlines [ "mylabel : if (.true.) then", "print *, 'foo'", "end if mylabel"]
+            trueLit = ExpValue () u (ValLogical ".true.")
+            ifBlock = BlIf () u Nothing (Just "mylabel") [Just trueLit] [[BlStatement () u Nothing stPrint]] Nothing
+        blParser ifBlockSrc `shouldBe'` ifBlock
 
-      it "parses end if statement" $
-        sParser "end if" `shouldBe'` StEndif () u Nothing
+      it "parses if-else block with inline comments (stripped)" $
+        let ifBlockSrc = unlines [ "if (.false.) then ! comment if", "print *, 'foo'", "else ! comment else", "print *, 'foo'", "end if ! comment end"]
+            falseLit = ExpValue () u (ValLogical ".false.")
+        in blParser ifBlockSrc `shouldBe'` BlIf () u Nothing Nothing [Just falseLit, Nothing] [[BlStatement () u Nothing stPrint], [BlStatement () u Nothing stPrint]] Nothing
 
       it "parses logical if statement" $ do
         let assignment = StExpressionAssign () u (varGen "a") (varGen "b")
@@ -512,24 +517,45 @@
         sParser "if (x) 1, 2, 3" `shouldBe'` stIf
 
     describe "Case" $ do
-      it "parses select case statement" $ do
-        let st = StSelectCase () u Nothing (varGen "n")
-        sParser "select case (n)" `shouldBe'` st
-
-      it "parses select case statement with construct name" $ do
-        let st = StSelectCase () u (Just "case") (varGen "n")
-        sParser "case: select case (n)" `shouldBe'` st
-
-      it "parses case statement" $ do
-        let ranges = AList () u [ IxRange () u (Just $ intGen 42) Nothing Nothing ]
-        sParser "case (42:)" `shouldBe'` StCase () u Nothing (Just ranges)
-
-      it "parses case statement" $
-        sParser "case default" `shouldBe'` StCase () u Nothing Nothing
-
-      it "parses end select statement" $ do
-        let st = StEndcase () u (Just "name")
-        sParser "end select name" `shouldBe'` st
+      let printArgs str = Just $ AList () u [ExpValue () u $ ValString str]
+          printStmt = StPrint () u (ExpValue () u ValStar) . printArgs
+          printBlock = BlStatement () u Nothing . printStmt
+          intLit = ExpValue () u . ValInteger
+          ind2 = AList () u . pure $ IxSingle () u Nothing $ intLit "2"
+          ind3Plus = AList () u . pure $ IxRange () u (Just $ intLit "3") Nothing Nothing
+          conds = [Just ind2, Just ind3Plus, Nothing]
+      it "unlabelled case block (with inline comments to be stripped)" $ do
+        let src = unlines [ "select case (x) ! comment select"
+                          , "! full line before first case (unrepresentable)"
+                          , "case (2) ! comment case 1"
+                          , "print *, 'foo'"
+                          , "case (3:) ! comment case 2"
+                          , "print *, 'bar'"
+                          , "case default ! comment case 3"
+                          , "print *, 'baz'"
+                          , "end select ! comment end"
+                          ]
+            blocks = (fmap . fmap) printBlock [["foo"], ["bar"], ["baz"]]
+            block = BlCase () u Nothing Nothing (varGen "x") conds blocks Nothing
+        blParser src `shouldBe'` block
+      it "labelled case block (with inline comments to be stripped" $ do
+        let src = unlines [ "10 mylabel: select case (x) ! comment select"
+                          , "20 case (2) ! comment case 1"
+                          , "30 print *, 'foo'"
+                          , "40 case (3:) ! comment case 2"
+                          , "50 print *, 'bar'"
+                          , "60 case default ! comment case 3"
+                          , "70 print *, 'baz'"
+                          , "80 end select mylabel ! comment end"
+                          ]
+            blocks = (fmap . fmap)
+                     (\(label, arg) -> BlStatement () u (Just $ intLit label) $ printStmt arg)
+                     [[("30", "foo")], [("50", "bar")], [("70", "baz")]]
+            block = BlCase () u
+                           (Just $ intLit "10") (Just "mylabel") (varGen "x")
+                           conds blocks
+                           (Just $ intLit "80")
+        blParser src `shouldBe'` block
 
     describe "Do" $ do
       it "parses do statement with label" $ do
@@ -552,9 +578,18 @@
         let st = StEnddo () u (Just "constructor")
         sParser "end do constructor" `shouldBe'` st
 
-      it "parses end do while statement" $ do
+    describe "DO WHILE" $ do
+      it "parses unnamed do while statement" $ do
+        let st = StDoWhile () u Nothing Nothing valTrue
+        sParser "do while (.true.)" `shouldBe'` st
+
+      it "parses named do while statement" $ do
         let st = StDoWhile () u (Just "name") Nothing valTrue
         sParser "name: do while (.true.)" `shouldBe'` st
+
+      it "parses unnamed labelled do while statement" $ do
+        let st = StDoWhile () u Nothing (Just (intGen 999)) valTrue
+        sParser "do 999 while (.true.)" `shouldBe'` st
 
     describe "Goto" $ do
       it "parses vanilla goto" $ do
diff --git a/test/Language/Fortran/Parser/UtilsSpec.hs b/test/Language/Fortran/Parser/UtilsSpec.hs
--- a/test/Language/Fortran/Parser/UtilsSpec.hs
+++ b/test/Language/Fortran/Parser/UtilsSpec.hs
@@ -77,4 +77,4 @@
         jExp a b c = Just (Exponent a b c)
         expE = ExpLetterE
         expD = ExpLetterD
-        fails test = return test `shouldThrow` anyException
+        -- fails test = return test `shouldThrow` anyException
diff --git a/test/Language/Fortran/PrettyPrintSpec.hs b/test/Language/Fortran/PrettyPrintSpec.hs
--- a/test/Language/Fortran/PrettyPrintSpec.hs
+++ b/test/Language/Fortran/PrettyPrintSpec.hs
@@ -81,15 +81,15 @@
         pprint Fortran90 impList Nothing `shouldBe` "integer (x, a-z, o)"
 
     describe "Common group" $ do
-      let globs = [ varGen "x", varGen "y", varGen "z" ]
+      let globs = [ declVarGen "x", declVarGen "y", declVarGen "z" ]
 
       it "prints anonymous common group" $ do
         let group = CommonGroup () u Nothing (AList () u globs)
-        pprint Fortran66 group Nothing `shouldBe` "//x, y, z"
+        pprint Fortran66 group Nothing `shouldBe` "// x, y, z"
 
       it "prints named common group" $ do
         let group = CommonGroup () u (Just $ varGen "my_g") (AList () u globs)
-        pprint Fortran66 group Nothing `shouldBe` "/my_g/x, y, z"
+        pprint Fortran66 group Nothing `shouldBe` "/my_g/ x, y, z"
 
     describe "Format item" $
       it "prints hollerith constant" $ do
@@ -209,10 +209,6 @@
           let logIf = StIfLogical () u valFalse as
           pprint Fortran90 logIf Nothing `shouldBe` "if (.false.) x = 42"
 
-        it "prints named if-then" $ do
-          let ifThen = StIfThen () u (Just "mistral") valTrue
-          pprint Fortran90 ifThen Nothing `shouldBe` "mistral: if (.true.) then"
-
       describe "Case" $ do
         it "prints select case" $ do
           let sc = StSelectCase () u Nothing (varGen "x")
@@ -407,6 +403,43 @@
                                , "    i = (i - 1)"
                                , "42 end select" ]
           pprint Fortran90 bl (Just 0) `shouldBe` text expect
+
+      describe "Case" $
+        it "prints multi-case select case construct" $ do
+          let range = IxRange () u (Just $ intGen 2) (Just $ intGen 4) Nothing
+          let cases = [ Just (AList () u [range])
+                      , Just (AList () u [ IxSingle () u Nothing (intGen 7) ])
+                      , Nothing ]
+          let bodies = replicate 3 body
+          let bl = BlCase () u Nothing Nothing (varGen "x") cases bodies (Just (intGen 42))
+          let expect = unlines [ "select case (x)"
+                               , "  case (2:4)"
+                               , "    print *, i"
+                               , "    i = (i - 1)"
+                               , "  case (7)"
+                               , "    print *, i"
+                               , "    i = (i - 1)"
+                               , "  case default"
+                               , "    print *, i"
+                               , "    i = (i - 1)"
+                               , "42 end select" ]
+          pprint Fortran90 bl (Just 0) `shouldBe` text expect
+
+      describe "Associate" $
+        it "prints multi-abbreviation associate block (Fortran2003)" $ do
+          let bl      = BlAssociate () u Nothing Nothing abbrevs body' Nothing
+              body'   = [blStmtPrint "x", blStmtPrint "y"]
+              blStmtPrint x = BlStatement () u Nothing (stmtPrint x)
+              stmtPrint x = StPrint () u starVal (Just $ AList () u [ varGen x ])
+              abbrevs = AList () u [abbrev "x" (expValVar "a"), abbrev "y" (expBinVars Multiplication "a" "b")]
+              abbrev var expr = ATuple () u (expValVar var) expr
+              expValVar x = ExpValue () u (ValVariable x)
+              expBinVars op x1 x2 = ExpBinary () u op (expValVar x1) (expValVar x2)
+          let expect = unlines [ "associate (x => a, y => (a * b))"
+                               , "  print *, x"
+                               , "  print *, y"
+                               , "end associate" ]
+          pprint Fortran2003 bl (Just 0) `shouldBe` text expect
 
     describe "Program units" $ do
       describe "Main" $ do
diff --git a/test/Language/Fortran/RewriterSpec.hs b/test/Language/Fortran/RewriterSpec.hs
--- a/test/Language/Fortran/RewriterSpec.hs
+++ b/test/Language/Fortran/RewriterSpec.hs
@@ -455,8 +455,16 @@
   c2 <- BC.readFile actual
   compareByteString c1 c2
 
+-- XXX: It appears the rewriter has different behaviour on Windows and Linux --
+--      specifically relating to newlines. So we use a custom equality check
+--      that skips Windows newlines (@\r@ characters are skipped).
+--
+--      (This is morally grey: the issue is unlikely to rear its head in
+--      practical usage, _but_ if you were to be comparing rewriter output from
+--      different platforms, you may encounter it. Most cross-platform text
+--      tooling recognises/ignores Windows newlines, however.)
 compareByteString :: BC.ByteString -> BC.ByteString -> IO Bool
-compareByteString expected actual = if expected == actual
+compareByteString expected actual = if expected `eqSkipWinNewlines` actual
   then return True
   else do
     BC.putStrLn ">>>>>>> EXPECTED"
@@ -464,3 +472,25 @@
     BC.putStrLn ">>>>>>> ACTUAL"
     BC.putStrLn actual
     return False
+
+eqSkipWinNewlines :: BC.ByteString -> BC.ByteString -> Bool
+eqSkipWinNewlines x1 x2 = go (BC.uncons x1) (BC.uncons x2)
+  where
+    go :: Maybe (Char, BC.ByteString) -> Maybe (Char, BC.ByteString) -> Bool
+
+    -- both reached EOF simultaneously: identical
+    go Nothing Nothing = True
+
+    -- next character in either bytestring is @\r@: skip
+    go (Just ('\r', bs1)) bs2 = go (BC.uncons bs1) bs2
+    go bs1 (Just ('\r', bs2)) = go bs1 (BC.uncons bs2)
+
+    -- only one bytestring is EOF: different
+    go Nothing (Just _)       = False
+    go (Just _) Nothing       = False
+
+    -- main case: check equality of next words
+    go (Just (b1, bs1)) (Just (b2, bs2)) =
+        if   b1 == b2
+        then go (BC.uncons bs1) (BC.uncons bs2)
+        else False
diff --git a/test/Language/Fortran/Transformation/GroupingSpec.hs b/test/Language/Fortran/Transformation/GroupingSpec.hs
--- a/test/Language/Fortran/Transformation/GroupingSpec.hs
+++ b/test/Language/Fortran/Transformation/GroupingSpec.hs
@@ -14,8 +14,6 @@
 import Language.Fortran.Parser.Fortran95
 import Language.Fortran.Parser.Fortran77
 
-groupIf :: ProgramFile () -> ProgramFile ()
-groupIf = transform [ GroupIf ]
 groupDo :: ProgramFile () -> ProgramFile ()
 groupDo = transform [ GroupLabeledDo ]
 groupForall :: ProgramFile () -> ProgramFile ()
@@ -33,13 +31,7 @@
     it "groups unlabelled FORALL blocks" $ do
       let lhs = (evaluate . force) (groupForall $ exampleForall name endName)
       lhs `shouldThrow` anyErrorCall
-  describe "Block IF-THEN and related statements" $ do
-    it "groups example1" $
-      groupIf example1 `shouldBe'` expectedExample1
 
-    it "groups example2" $
-      groupIf example2 `shouldBe'` expectedExample2
-
   describe "Block DO statements" $ do
     it "do group example1" $
       groupDo example1do `shouldBe` expectedExample1do
@@ -78,58 +70,6 @@
 expectedForall :: Maybe String -> ProgramFile ()
 expectedForall name  = buildExampleProgram "forall"
     [BlForall () u Nothing name exampleHeader [exampleComment] Nothing]
-
-
--- if (.true.) then
--- end if
-example1 :: ProgramFile ()
-example1 = ProgramFile mi77 [ PUMain () u (Just "example1") example1Blocks Nothing ]
-example1Blocks :: [Block ()]
-example1Blocks =
-  [ BlStatement () u Nothing (StIfThen () u Nothing valTrue)
-  , BlStatement () u Nothing (StEndif () u Nothing) ]
-
-expectedExample1 :: ProgramFile ()
-expectedExample1 = ProgramFile mi77 [ PUMain () u (Just "example1") expectedExample1Blocks Nothing ]
-expectedExample1Blocks :: [Block ()]
-expectedExample1Blocks = [ BlIf () u Nothing Nothing [ Just valTrue ] [ [ ] ] Nothing ]
-
--- if (.true.) then
---   integer x
---   if (.false.) then
---   endif
--- else if (.true.) then
--- else
---   if (.false.) then
---   endif
--- end if
-example2 :: ProgramFile ()
-example2 = ProgramFile mi77 [ PUMain () u (Just "example2") example2Blocks Nothing ]
-example2Blocks :: [Block ()]
-example2Blocks =
-  [ BlStatement () u Nothing (StIfThen () u Nothing valTrue)
-  , BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ DeclVariable () u (varGen "x") Nothing Nothing ]))
-  , BlStatement () u Nothing (StIfThen () u Nothing valFalse)
-  , BlStatement () u Nothing (StEndif () u Nothing)
-  , BlStatement () u Nothing (StElsif () u Nothing valTrue)
-  , BlStatement () u Nothing (StElse () u Nothing)
-  , BlStatement () u Nothing (StIfThen () u Nothing valFalse)
-  , BlStatement () u Nothing (StEndif () u Nothing)
-  , BlStatement () u Nothing (StEndif () u Nothing) ]
-
-expectedExample2 :: ProgramFile ()
-expectedExample2 = ProgramFile mi77 [ PUMain () u (Just "example2") expectedExample2Blocks Nothing ]
-expectedExample2Blocks :: [Block ()]
-expectedExample2Blocks = [ BlIf () u Nothing Nothing [ Just valTrue, Just valTrue, Nothing ] blockGroups Nothing ]
-blockGroups :: [[Block ()]]
-blockGroups =
-  [ [ BlStatement () u Nothing (StDeclaration () u (TypeSpec () u TypeInteger Nothing) Nothing (AList () u [ DeclVariable () u (varGen "x") Nothing Nothing ]))
-    , innerIf ]
-  , [ ]
-  , [ innerIf ] ]
-innerIf :: Block ()
-innerIf = BlIf () u Nothing Nothing [ Just valFalse ] [ [ ] ] Nothing
-
 
 -- do 10 i = 0, 10
 -- 10   continue
diff --git a/test/TestUtil.hs b/test/TestUtil.hs
--- a/test/TestUtil.hs
+++ b/test/TestUtil.hs
@@ -32,6 +32,9 @@
 varGen :: String -> Expression ()
 varGen str = ExpValue () u $ ValVariable str
 
+declVarGen :: String -> Declarator ()
+declVarGen str = DeclVariable () u (varGen str) Nothing Nothing
+
 intGen :: Integer -> Expression ()
 intGen i = ExpValue () u $ ValInteger $ show i