├── .gitignore ├── LICENSE ├── README ├── Setup.hs ├── TODO ├── language-fortran.cabal ├── src ├── Language │ ├── Fortran.hs │ └── Fortran │ │ ├── Lexer.x │ │ ├── Parser.y │ │ ├── PreProcess.hs │ │ └── Pretty.hs ├── LexerTest.hs └── ParserTest.hs └── test.f90 /.gitignore: -------------------------------------------------------------------------------- 1 | cabal-dev/ 2 | dist/ 3 | *.swp 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012, Jason Dagit 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Jason Dagit nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Language-Fortran 2 | ----------------------------------- 3 | 0. Prerequisites 4 | 5 | For Debian/Ubuntu: 6 | 7 | sudo apt-get install ghc alex happy libghc-haskell-src-dev 8 | 9 | 1. Installing 10 | ----------------------------------- 11 | 12 | To install as a library in your Haskell build 13 | 14 | runhaskell Setup.hs configure 15 | runhaskell Setup.hs build 16 | runhaskell Setup.hs install 17 | 18 | OR, for local install (depending how your Haskell install is setup), try to configure 19 | using --user. 20 | 21 | runhaskell Setup.hs configure --user 22 | 23 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | Bugs 2 | 3 | * Variables that look like exponents, e.g., E2, are not parsed 4 | * Support passing by reference -------------------------------------------------------------------------------- /language-fortran.cabal: -------------------------------------------------------------------------------- 1 | name: language-fortran 2 | version: 0.3 3 | synopsis: Fortran lexer and parser, language support, and extensions. 4 | description: 5 | Lexer and parser for Fortran roughly supporting standards from 6 | FORTRAN 77 to Fortran 2003 (but with some patches and rough 7 | edges). Also includes language extension support for 8 | units-of-measure typing. 9 | license: BSD3 10 | license-file: LICENSE 11 | author: Jason Dagit, Dominic Orchard, Oleg Oshmyan 12 | maintainer: dagitj@gmail.com, dom.orchard@gmail.com 13 | bug-reports: https://github.com/dagit/language-fortran/issues 14 | -- copyright: 15 | category: Language 16 | build-type: Simple 17 | cabal-version: >=1.8 18 | 19 | source-repository head 20 | type: git 21 | location: https://github.com/dagit/language-fortran 22 | 23 | library 24 | ghc-options: -Wall 25 | exposed-modules: Language.Fortran.Parser, 26 | Language.Fortran.Lexer, 27 | Language.Fortran.Pretty, 28 | Language.Fortran.PreProcess, 29 | Language.Fortran 30 | -- other-modules: 31 | build-depends: base >=4.0 && < 5, 32 | syb >= 0.3, 33 | haskell-src >= 1.0, 34 | parsec, 35 | array >= 0.4 36 | 37 | hs-source-dirs: src 38 | build-tools: alex, happy 39 | -------------------------------------------------------------------------------- /src/Language/Fortran.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor, DeriveDataTypeable #-} 2 | -- | 3 | -- Based on FortranP.hs from Parameterized Fortran by Martin Erwig. 4 | -- 5 | -- Language definition for Fortran (covers a lot of standards, but still incomplete) 6 | -- 7 | -- The AST is parameterised by type variable p which allows all nodes 8 | -- of the AST to be annotated. The default annotation is (). This is 9 | -- useful for analysis. The 'Tagged' type class provides the function 10 | -- @tag :: d a -> a@ to extract these annotations. 11 | -- 12 | -- Furthermore, many nodes of the tree have a 'SrcSpan' which is the 13 | -- start and end locations of the syntax in the source file (including 14 | -- whitespace etc.) This is useful for error reporting and 15 | -- refactoring. The 'Span' type class provides the function @srcSpan 16 | -- :: d a -> SrcSpan@ which which extracts the span (where possible) 17 | module Language.Fortran where 18 | 19 | -------------------------------------------------------------------------- 20 | -- IMPORTS 21 | --------------------------------------------------------------------------- 22 | 23 | import Data.Generics -- Typeable class and boilerplate generic functions 24 | -- All AST nodes are members of 'Data' and 'Typeable' so that 25 | -- data type generic programming can be done with the AST 26 | 27 | 28 | ----------------------------------------------------------------------------------- 29 | 30 | ----------------------------------------------------------------------------------- 31 | 32 | data SrcLoc = SrcLoc { 33 | srcFilename :: String, 34 | srcLine :: Int, 35 | srcColumn :: Int 36 | } 37 | deriving (Eq, Typeable, Data) 38 | 39 | instance Show SrcLoc where 40 | -- A special instance if the filename is set to "compact" to reduce size of outputs 41 | show (SrcLoc "compact" l c) = "{l" ++ show l ++ ",c" ++ show c ++ "}" 42 | show (SrcLoc f l c) = "{" ++ f ++ ", line = " ++ show l ++ ", col = " ++ show c ++ "}" 43 | 44 | 45 | type SrcSpan = (SrcLoc, SrcLoc) 46 | 47 | type Variable = String 48 | 49 | -- | Fortran program names 50 | type ProgName = String 51 | 52 | -- | Fortran subroutine names 53 | data SubName p = SubName p String 54 | | NullSubName p 55 | deriving (Show, Functor, Typeable, Data, Eq) 56 | 57 | data VarName p = VarName p Variable 58 | deriving (Show, Functor, Typeable, Data, Eq, Read) 59 | 60 | data ArgName p = ArgName p String 61 | | ASeq p (ArgName p) (ArgName p) 62 | | NullArg p 63 | deriving (Show, Functor, Typeable, Data, Eq) 64 | 65 | -- Syntax defintions 66 | -- 67 | 68 | -- | The src span denotes the end of the arg list before ')' 69 | data Arg p = Arg p (ArgName p) SrcSpan 70 | deriving (Show, Functor, Typeable, Data, Eq) 71 | 72 | data ArgList p = ArgList p (Expr p) 73 | deriving (Show, Functor, Typeable, Data, Eq) 74 | 75 | type Program p = [ProgUnit p] 76 | 77 | -- Prog type (type of result) name args (result) body use's 78 | data ProgUnit p = Main p SrcSpan (SubName p) (Arg p) (Block p) [ProgUnit p] 79 | | Sub p SrcSpan (Maybe (BaseType p)) (SubName p) (Arg p) (Block p) 80 | | Function p SrcSpan (Maybe (BaseType p)) (SubName p) (Arg p) (Maybe (VarName p)) (Block p) 81 | | Module p SrcSpan (SubName p) (Uses p) (Implicit p) (Decl p) [ProgUnit p] 82 | | BlockData p SrcSpan (SubName p) (Uses p) (Implicit p) (Decl p) 83 | | PSeq p SrcSpan (ProgUnit p) (ProgUnit p) -- sequence of programs 84 | | Prog p SrcSpan (ProgUnit p) -- useful for {#p: #q : program ... } 85 | | NullProg p SrcSpan -- null 86 | | IncludeProg p SrcSpan (Decl p) (Maybe (Fortran p)) 87 | deriving (Show, Functor, Typeable, Data, Eq) 88 | 89 | -- | Implicit none or no implicit 90 | data Implicit p = ImplicitNone p | ImplicitNull p 91 | deriving (Show, Functor, Typeable, Data, Eq) 92 | 93 | -- | renames for "use"s 94 | type Renames = [(Variable, Variable)] 95 | 96 | data UseBlock p = UseBlock (Uses p) SrcLoc deriving (Show, Functor, Typeable, Data, Eq) 97 | 98 | -- | (second 'p' let's you annotate the 'cons' part of the cell) 99 | data Uses p = Use p (String, Renames) (Uses p) p 100 | | UseNil p deriving (Show, Functor, Typeable, Data, Eq) 101 | 102 | -- use's implicit decls stmts 103 | data Block p = Block p (UseBlock p) (Implicit p) SrcSpan (Decl p) (Fortran p) 104 | deriving (Show, Functor, Typeable, Data, Eq) 105 | 106 | data Decl p = Decl p SrcSpan [(Expr p, Expr p, Maybe Int)] (Type p) -- declaration stmt 107 | | Namelist p [(Expr p, [Expr p])] -- namelist declaration 108 | | DataDecl p (DataForm p) 109 | | Equivalence p SrcSpan [(Expr p)] 110 | | AttrStmt p (Attr p) [(Expr p, Expr p, Maybe Int)] 111 | | AccessStmt p (Attr p) [GSpec p] -- access stmt 112 | | ExternalStmt p [String] -- external stmt 113 | | Interface p (Maybe (GSpec p)) [InterfaceSpec p] -- interface declaration 114 | | Common p SrcSpan (Maybe String) [Expr p] 115 | | DerivedTypeDef p SrcSpan (SubName p) [Attr p] [Attr p] [Decl p] -- derivified 116 | | Include p (Expr p) -- include stmt 117 | | DSeq p (Decl p) (Decl p) -- list of decls 118 | | TextDecl p String -- cpp switches to carry over 119 | | NullDecl p SrcSpan -- null 120 | -- units-of-measure extension 121 | | MeasureUnitDef p SrcSpan [(MeasureUnit, MeasureUnitSpec p)] 122 | deriving (Show, Functor, Typeable, Data, Eq) 123 | 124 | -- BaseType dimensions type Attributes kind len 125 | data Type p = BaseType p (BaseType p) [Attr p] (Expr p) (Expr p) 126 | | ArrayT p [(Expr p, Expr p)] (BaseType p) [Attr p] (Expr p) (Expr p) 127 | deriving (Show, Functor, Typeable, Data, Eq) 128 | 129 | data BaseType p = Integer p | Real p | Character p | SomeType p | DerivedType p (SubName p) 130 | | Recursive p | Pure p | Elemental p | Logical p | Complex p 131 | deriving (Show, Functor, Typeable, Data, Eq) 132 | 133 | data Attr p = Parameter p 134 | | Allocatable p 135 | | External p 136 | | Intent p (IntentAttr p) 137 | | Intrinsic p 138 | | Optional p 139 | | Pointer p 140 | | Save p 141 | | Target p 142 | | Volatile p 143 | | Public p 144 | | Private p 145 | | Sequence p 146 | | Dimension p [(Expr p, Expr p)] 147 | -- units-of-measure extension 148 | | MeasureUnit p (MeasureUnitSpec p) 149 | deriving (Show, Functor, Typeable, Data, Eq) 150 | 151 | 152 | {- start: units-of-measure extension -} 153 | type MeasureUnit = String 154 | 155 | data MeasureUnitSpec p = UnitProduct p [(MeasureUnit, Fraction p)] 156 | | UnitQuotient p [(MeasureUnit, Fraction p)] [(MeasureUnit, Fraction p)] 157 | | UnitNone p 158 | deriving (Show, Functor, Typeable, Data, Eq) 159 | 160 | data Fraction p = IntegerConst p String 161 | | FractionConst p String String 162 | | NullFraction p 163 | deriving (Show, Functor, Typeable, Data, Eq) 164 | {- end -} 165 | 166 | 167 | data GSpec p = GName p (Expr p) | GOper p (BinOp p) | GAssg p 168 | deriving (Show, Functor, Typeable, Data, Eq) 169 | 170 | data InterfaceSpec p = FunctionInterface p (SubName p) (Arg p) (Uses p) (Implicit p) (Decl p) 171 | | SubroutineInterface p (SubName p) (Arg p) (Uses p) (Implicit p) (Decl p) 172 | | ModuleProcedure p [(SubName p)] 173 | deriving (Show, Functor, Typeable, Data, Eq) 174 | 175 | data DataForm p = Data p [(Expr p, Expr p)] deriving (Show, Functor, Typeable, Data, Eq) -- data declaration 176 | 177 | data IntentAttr p = In p 178 | | Out p 179 | | InOut p 180 | deriving (Show, Functor, Typeable, Data, Eq) 181 | 182 | data Fortran p = Assg p SrcSpan (Expr p) (Expr p) 183 | | For p SrcSpan (VarName p) (Expr p) (Expr p) (Expr p) (Fortran p) 184 | | DoWhile p SrcSpan (Expr p) (Fortran p) 185 | | FSeq p SrcSpan (Fortran p) (Fortran p) 186 | | If p SrcSpan (Expr p) (Fortran p) [((Expr p),(Fortran p))] (Maybe (Fortran p)) 187 | | Allocate p SrcSpan (Expr p) (Expr p) 188 | | Backspace p SrcSpan [Spec p] 189 | | Call p SrcSpan (Expr p) (ArgList p) 190 | | Open p SrcSpan [Spec p] 191 | | Close p SrcSpan [Spec p] 192 | | Continue p SrcSpan 193 | | Cycle p SrcSpan String 194 | | DataStmt p SrcSpan (DataForm p) 195 | | Deallocate p SrcSpan [(Expr p)] (Expr p) 196 | | Endfile p SrcSpan [Spec p] 197 | | Exit p SrcSpan String 198 | | Format p SrcSpan [Spec p] 199 | | Forall p SrcSpan ([(String,(Expr p),(Expr p),(Expr p))],(Expr p)) (Fortran p) 200 | | Goto p SrcSpan String 201 | | Nullify p SrcSpan [(Expr p)] 202 | | Inquire p SrcSpan [Spec p] [(Expr p)] 203 | | Pause p SrcSpan String 204 | | Rewind p SrcSpan [Spec p] 205 | | Stop p SrcSpan (Expr p) 206 | | Where p SrcSpan (Expr p) (Fortran p) (Maybe (Fortran p)) 207 | | Write p SrcSpan [Spec p] [(Expr p)] 208 | | PointerAssg p SrcSpan (Expr p) (Expr p) 209 | | Return p SrcSpan (Expr p) 210 | | Label p SrcSpan String (Fortran p) 211 | | Print p SrcSpan (Expr p) [(Expr p)] 212 | | ReadS p SrcSpan [Spec p] [(Expr p)] 213 | | TextStmt p SrcSpan String -- cpp switches to carry over 214 | | NullStmt p SrcSpan 215 | deriving (Show, Functor, Typeable, Data, Eq) 216 | 217 | -- type Bound = ((Expr p),(Expr p)) 218 | 219 | data Expr p = Con p SrcSpan String 220 | | ConL p SrcSpan Char String 221 | | ConS p SrcSpan String -- String representing a constant 222 | | Var p SrcSpan [(VarName p, [Expr p])] 223 | | Bin p SrcSpan (BinOp p) (Expr p) (Expr p) 224 | | Unary p SrcSpan (UnaryOp p) (Expr p) 225 | | CallExpr p SrcSpan (Expr p) (ArgList p) 226 | | NullExpr p SrcSpan 227 | | Null p SrcSpan 228 | | ESeq p SrcSpan (Expr p) (Expr p) 229 | | Bound p SrcSpan (Expr p) (Expr p) 230 | | Sqrt p SrcSpan (Expr p) 231 | | ArrayCon p SrcSpan [(Expr p)] 232 | | AssgExpr p SrcSpan String (Expr p) 233 | deriving (Show, Functor, Typeable ,Data, Eq) 234 | 235 | data BinOp p = Plus p 236 | | Minus p 237 | | Mul p 238 | | Div p 239 | | Or p 240 | | And p 241 | | Concat p 242 | | Power p 243 | | RelEQ p 244 | | RelNE p 245 | | RelLT p 246 | | RelLE p 247 | | RelGT p 248 | | RelGE p 249 | deriving (Show, Functor, Typeable, Data, Eq) 250 | 251 | data UnaryOp p = UMinus p | Not p 252 | deriving (Show, Functor,Typeable,Data, Eq) 253 | 254 | data Spec p = Access p (Expr p) 255 | | Action p (Expr p) 256 | | Advance p (Expr p) 257 | | Blank p (Expr p) 258 | | Delim p (Expr p) 259 | | Direct p (Expr p) 260 | | End p (Expr p) 261 | | Err p (Expr p) 262 | | ExFile p (Expr p) 263 | | Exist p (Expr p) 264 | | Eor p (Expr p) 265 | | File p (Expr p) 266 | | FMT p (Expr p) 267 | | Form p (Expr p) 268 | | Formatted p (Expr p) 269 | | Unformatted p (Expr p) 270 | | IOLength p (Expr p) 271 | | IOStat p (Expr p) 272 | | Name p (Expr p) 273 | | Named p (Expr p) 274 | | NoSpec p (Expr p) 275 | | Number p (Expr p) 276 | | Floating p (Expr p) (Expr p) 277 | | NextRec p (Expr p) 278 | | NML p (Expr p) 279 | | Opened p (Expr p) 280 | | Pad p (Expr p) 281 | | Position p (Expr p) 282 | | Read p (Expr p) 283 | | ReadWrite p (Expr p) 284 | | Rec p (Expr p) 285 | | Recl p (Expr p) 286 | | Sequential p (Expr p) 287 | | Size p (Expr p) 288 | | Status p (Expr p) 289 | | StringLit p String 290 | | Unit p (Expr p) 291 | | WriteSp p (Expr p) 292 | | Delimiter p 293 | deriving (Show, Functor,Typeable,Data, Eq) 294 | 295 | -- Extract span information from the source tree 296 | 297 | class Span t where 298 | srcSpan :: t -> (SrcLoc, SrcLoc) 299 | 300 | instance Span (Block a) where 301 | srcSpan (Block _ _ _ sp _ _) = sp 302 | 303 | instance Span (Decl a) where 304 | srcSpan (Decl _ sp _ _) = sp 305 | srcSpan (NullDecl _ sp) = sp 306 | srcSpan (Common _ sp _ _) = sp 307 | srcSpan (Equivalence x sp _) = sp 308 | srcSpan (DerivedTypeDef x sp _ _ _ _) = sp 309 | srcSpan (MeasureUnitDef x sp _) = sp 310 | srcSpan _ = error "No span for non common/equiv/type/ null declarations" 311 | 312 | instance Span (ProgUnit a) where 313 | srcSpan (Main x sp _ _ _ _) = sp 314 | srcSpan (Sub x sp _ _ _ _) = sp 315 | srcSpan (Function x sp _ _ _ _ _) = sp 316 | srcSpan (Module x sp _ _ _ _ _ ) = sp 317 | srcSpan (BlockData x sp _ _ _ _) = sp 318 | srcSpan (PSeq x sp _ _) = sp 319 | srcSpan (Prog x sp _) = sp 320 | srcSpan (NullProg x sp) = sp 321 | 322 | instance Span (Expr a) where 323 | srcSpan (Con x sp _) = sp 324 | srcSpan (ConS x sp _) = sp 325 | srcSpan (Var x sp _ ) = sp 326 | srcSpan (Bin x sp _ _ _) = sp 327 | srcSpan (Unary x sp _ _) = sp 328 | srcSpan (CallExpr x sp _ _) = sp 329 | srcSpan (NullExpr x sp) = sp 330 | srcSpan (Null x sp) = sp 331 | srcSpan (ESeq x sp _ _) = sp 332 | srcSpan (Bound x sp _ _) = sp 333 | srcSpan (Sqrt x sp _) = sp 334 | srcSpan (ArrayCon x sp _) = sp 335 | srcSpan (AssgExpr x sp _ _) = sp 336 | 337 | instance Span (Fortran a) where 338 | srcSpan (Assg x sp e1 e2) = sp 339 | srcSpan (For x sp v e1 e2 e3 fs) = sp 340 | srcSpan (DoWhile x sp e fs) = sp 341 | srcSpan (FSeq x sp f1 f2) = sp 342 | srcSpan (If x sp e f1 fes f3) = sp 343 | srcSpan (Allocate x sp e1 e2) = sp 344 | srcSpan (Backspace x sp _) = sp 345 | srcSpan (Call x sp e as) = sp 346 | srcSpan (Open x sp s) = sp 347 | srcSpan (Close x sp s) = sp 348 | srcSpan (Continue x sp) = sp 349 | srcSpan (Cycle x sp s) = sp 350 | srcSpan (DataStmt x sp _) = sp 351 | srcSpan (Deallocate x sp es e) = sp 352 | srcSpan (Endfile x sp s) = sp 353 | srcSpan (Exit x sp s) = sp 354 | srcSpan (Format x sp _) = sp 355 | srcSpan (Forall x sp es f) = sp 356 | srcSpan (Goto x sp s) = sp 357 | srcSpan (Nullify x sp e) = sp 358 | srcSpan (Inquire x sp s e) = sp 359 | srcSpan (Pause x sp _) = sp 360 | srcSpan (Rewind x sp s) = sp 361 | srcSpan (Stop x sp e) = sp 362 | srcSpan (Where x sp e f _) = sp 363 | srcSpan (Write x sp s e) = sp 364 | srcSpan (PointerAssg x sp e1 e2) = sp 365 | srcSpan (Return x sp e) = sp 366 | srcSpan (Label x sp s f) = sp 367 | srcSpan (Print x sp e es) = sp 368 | srcSpan (ReadS x sp s e) = sp 369 | srcSpan (TextStmt x sp s) = sp 370 | srcSpan (NullStmt x sp) = sp 371 | 372 | -- Extract the tag 373 | 374 | class Tagged d where 375 | tag :: d a -> a 376 | 377 | instance Tagged Attr where 378 | tag (Parameter x) = x 379 | tag (Allocatable x) = x 380 | tag (External x) = x 381 | tag (Intent x _) = x 382 | tag (Intrinsic x) = x 383 | tag (Optional x) = x 384 | tag (Pointer x) = x 385 | tag (Save x) = x 386 | tag (Target x) = x 387 | tag (Volatile x) = x 388 | tag (Public x) = x 389 | tag (Private x) = x 390 | tag (Sequence x) = x 391 | tag (Dimension x _) = x 392 | 393 | instance Tagged BaseType where 394 | tag (Integer x) = x 395 | tag (Real x) = x 396 | tag (Character x) = x 397 | tag (SomeType x) = x 398 | tag (DerivedType x _) = x 399 | tag (Recursive x) = x 400 | tag (Pure x) = x 401 | tag (Elemental x) = x 402 | tag (Logical x) = x 403 | tag (Complex x) = x 404 | 405 | instance Tagged SubName where 406 | tag (SubName x _) = x 407 | tag (NullSubName x) = x 408 | 409 | instance Tagged VarName where 410 | tag (VarName x _) = x 411 | 412 | instance Tagged Implicit where 413 | tag (ImplicitNone x) = x 414 | tag (ImplicitNull x) = x 415 | 416 | instance Tagged Uses where 417 | tag (Use x _ _ _) = x 418 | tag (UseNil x) = x 419 | 420 | instance Tagged Arg where 421 | tag (Arg x _ _) = x 422 | 423 | instance Tagged ArgList where 424 | tag (ArgList x _) = x 425 | 426 | instance Tagged ArgName where 427 | tag (ASeq x _ _) = x 428 | tag (NullArg x) = x 429 | tag (ArgName x _) = x 430 | 431 | instance Tagged ProgUnit where 432 | tag (Main x sp _ _ _ _) = x 433 | tag (Sub x sp _ _ _ _) = x 434 | tag (Function x sp _ _ _ _ _)= x 435 | tag (Module x sp _ _ _ _ _ ) = x 436 | tag (BlockData x sp _ _ _ _) = x 437 | tag (PSeq x sp _ _) = x 438 | tag (Prog x sp _) = x 439 | tag (NullProg x sp) = x 440 | 441 | instance Tagged Decl where 442 | tag (Decl x _ _ _) = x 443 | tag (Namelist x _) = x 444 | tag (DataDecl x _) = x 445 | tag (Equivalence x sp _) = x 446 | tag (AttrStmt x _ _) = x 447 | tag (AccessStmt x _ _) = x 448 | tag (ExternalStmt x _) = x 449 | tag (Interface x _ _) = x 450 | tag (Common x _ _ _) = x 451 | tag (DerivedTypeDef x sp _ _ _ _) = x 452 | tag (Include x _) = x 453 | tag (DSeq x _ _) = x 454 | tag (TextDecl x _) = x 455 | tag (NullDecl x _) = x 456 | tag (MeasureUnitDef x _ _) = x 457 | 458 | instance Tagged DataForm where 459 | tag (Data x _) = x 460 | 461 | instance Tagged Fortran where 462 | tag (Assg x s e1 e2) = x 463 | tag (For x s v e1 e2 e3 fs) = x 464 | tag (DoWhile x sp e fs) = x 465 | tag (FSeq x sp f1 f2) = x 466 | tag (If x sp e f1 fes f3) = x 467 | tag (Allocate x sp e1 e2) = x 468 | tag (Backspace x sp _) = x 469 | tag (Call x sp e as) = x 470 | tag (Open x sp s) = x 471 | tag (Close x sp s) = x 472 | tag (Continue x sp) = x 473 | tag (Cycle x sp s) = x 474 | tag (DataStmt x sp _) = x 475 | tag (Deallocate x sp es e) = x 476 | tag (Endfile x sp s) = x 477 | tag (Exit x sp s) = x 478 | tag (Format x sp _) = x 479 | tag (Forall x sp es f) = x 480 | tag (Goto x sp s) = x 481 | tag (Nullify x sp e) = x 482 | tag (Inquire x sp s e) = x 483 | tag (Pause x sp _) = x 484 | tag (Rewind x sp s) = x 485 | tag (Stop x sp e) = x 486 | tag (Where x sp e f _) = x 487 | tag (Write x sp s e) = x 488 | tag (PointerAssg x sp e1 e2) = x 489 | tag (Return x sp e) = x 490 | tag (Label x sp s f) = x 491 | tag (Print x sp e es) = x 492 | tag (ReadS x sp s e) = x 493 | tag (TextStmt x sp s) = x 494 | tag (NullStmt x sp) = x 495 | 496 | instance Tagged Expr where 497 | tag (Con x sp _) = x 498 | tag (ConL x sp _ _) = x 499 | tag (ConS x sp _) = x 500 | tag (Var x sp _ ) = x 501 | tag (Bin x sp _ _ _) = x 502 | tag (Unary x sp _ _) = x 503 | tag (CallExpr x sp _ _) = x 504 | tag (NullExpr x _) = x 505 | tag (Null x _) = x 506 | tag (ESeq x sp _ _) = x 507 | tag (Bound x sp _ _) = x 508 | tag (Sqrt x sp _) = x 509 | tag (ArrayCon x sp _) = x 510 | tag (AssgExpr x sp _ _) = x 511 | 512 | instance Tagged GSpec where 513 | tag (GName x _) = x 514 | tag (GOper x _) = x 515 | tag (GAssg x) = x 516 | -------------------------------------------------------------------------------- /src/Language/Fortran/Lexer.x: -------------------------------------------------------------------------------- 1 | { 2 | module Language.Fortran.Lexer ( 3 | Token(..) 4 | , AlexReturn(..) 5 | , alexScan 6 | , alexScanTokens 7 | , lexer 8 | , lexer' 9 | ) where 10 | 11 | import Data.Char 12 | import Language.Fortran 13 | import Language.Haskell.ParseMonad 14 | import Debug.Trace 15 | 16 | } 17 | 18 | %wrapper "basic" 19 | 20 | $letter = [a-zA-Z] 21 | $digit = [0-9] 22 | $bin_digit = [01] 23 | $oct_digit = [0-7] 24 | $hex_digit = [0-9A-Fa-f] 25 | $underscore = \_ 26 | $currency_symbol = \$ 27 | $at_sign = \@ 28 | $sign = [\+\-] 29 | $alphanumeric_charactor = [$letter $digit $underscore $currency_symbol $at_sign] 30 | 31 | @name = ($letter | $underscore) ($letter | $digit | $underscore | $currency_symbol | $at_sign)* 32 | @digit_string = $digit+ 33 | @signed_digit_string = $sign? @digit_string 34 | @line_space = ($white # \n)* 35 | 36 | @kind_param = @digit_string | @name 37 | @int_literal_constant = @digit_string (\_ @kind_param)? 38 | 39 | @comment = ("!".*\n) 40 | 41 | @w = @int_literal_constant 42 | @m = @int_literal_constant 43 | @d = @int_literal_constant 44 | @e = @int_literal_constant 45 | @data_edit_desc = (("I"|"B"|"O"|"Z") @w ( \. @m)?) | "F" @w \. @d | (("E"|"EN"|"ES"|"G") @w \. @d ("E" @e)?) | "L" @w | "A" @w? | @w "X" | "D" @w \. @d ("E" @e)? | "R" @w | "Q" 46 | 47 | @continuation_line_alt = \n$white*"&" | \n$white*"$" | \n$white*"+" 48 | 49 | @binary_constant_prefix = ("B" \' $digit+ \') | ("B" \" $digit+ \") 50 | @octal_constant_prefix = ("O" \' $digit+ \') | ("O" \" $digit+ \") 51 | @hex_constant_prefix = ("Z" \' $hex_digit+ \') | ("Z" \" $hex_digit+ \") 52 | @binary_constant_suffix = (\' $bin_digit+ \' "B") | (\" $bin_digit+ \" "B") 53 | @octal_constant_suffix = (\' $oct_digit+ \' "O") | (\" $oct_digit+ \""O") 54 | @hex_constant_suffix = ( \' $hex_digit+ \' "Z") | ( \" $hex_digit+ \" "Z") 55 | 56 | $exponent_letter = [EeDd] 57 | @exponent = @signed_digit_string 58 | @significand = (@digit_string \. @digit_string?) | (\. @digit_string) 59 | 60 | @real_literal_constant = (@significand ($white* $exponent_letter @exponent)? (\_ @kind_param)?) 61 | | (@digit_string $white* $exponent_letter @exponent (\_ @kind_param)?) 62 | 63 | --@signed_real_literal_constant = $sign? @real_literal_constant 64 | 65 | tokens :- 66 | \n\# .* $ { \s -> Text s } 67 | \n(C|c).*$ { \s -> ContLineAlt } -- Fortran 77 style comment 68 | \n { \s -> NewLine } 69 | ($white # \n)+ ; 70 | "#" { \s -> Hash } 71 | "->" { \s -> MArrow } 72 | "=>" { \s -> Arrow } 73 | "**" { \s -> OpPower } 74 | "//" { \s -> OpConcat } 75 | "." $white* "EQ" $white* "." | "." $white* "eq" $white* "." | "==" { \s -> OpEQ } 76 | "." $white* "NE" $white* "." | "." $white* "ne" $white* "." | "/=" { \s -> OpNE } 77 | "." $white* "LE" $white* "." | "." $white* "le" $white* "." | "<=" { \s -> OpLE } 78 | "." $white* "GE" $white* "." | "." $white* "ge" $white* "." | ">=" { \s -> OpGE } 79 | "." $white* "NOT" $white* "." | "." $white* "not" $white* "." { \s -> OpNOT } 80 | "." $white* "AND" $white* "." | "." $white* "and" $white* "." { \s -> OpAND } 81 | "." $white* "OR" $white* "." | "." $white* "or" $white* "." { \s -> OpOR } 82 | "." $white* "TRUE" $white* "." | "." $white* "true" $white* "." { \s -> TrueConst } 83 | "." $white* "FALSE" $white* "." | "." $white* "false" $white* "." { \s -> FalseConst } 84 | "." $white* "EQV" $white* "." | "." $white* "eqv" $white* "." { \s -> OpEQV } 85 | "." $white* "NEQV" $white* "." | "." $white* "neqv" $white* "." { \s -> OpNEQV } 86 | "." $white* "LT" $white* "." | "." $white* "lt" $white* "." | "<" { \s -> OpLT } 87 | "." $white* "GT" $white* "." | "." $white* "gt" $white* "." | ">" { \s -> OpGT } 88 | "*" { \s -> OpMul } 89 | "/" { \s -> OpDiv } 90 | "+" { \s -> OpAdd } 91 | "-" { \s -> OpSub } 92 | "," { \s -> Comma } 93 | "(/" { \s -> LArrCon } 94 | "/)" { \s -> RArrCon } 95 | "(" { \s -> LParen } 96 | ")" { \s -> RParen } 97 | "=" { \s -> OpEquals } 98 | \"(. # \")*\" { \s -> StrConst s } 99 | \'(. # \')*\' { \s -> StrConst s } 100 | \'(. # \')* @continuation_line_alt (. # \')*\' { \s -> StrConst (cutOutContLine s) } 101 | 102 | "Z"\'(. # \')*\' { \s -> LitConst 'z' s } 103 | "z"\'(. # \')*\' { \s -> LitConst 'z' s } 104 | \' { \s -> SingleQuote } 105 | \. { \s -> Period } 106 | "::" { \s -> ColonColon } 107 | ":" { \s -> Colon } 108 | ";" { \s -> SemiColon } 109 | "$" { \s -> Dollar } 110 | "NULL()" { \s -> Key "null" } 111 | -- "&" ; -- ignore & anywhere 112 | @continuation_line_alt { \s -> ContLineAlt } 113 | \n "!".* \n $white*"&" { \s -> ContLineWithComment } 114 | $white*"&"$white*\n { \s -> ContLine } -- ignore & and spaces followed by '\n' (continuation line) 115 | ($white # \r # \n)*"&" { \s -> ContLineNoNewLine } 116 | "!".*$ ; 117 | "%" { \s -> Percent } 118 | "{" { \s -> LBrace } 119 | "}" { \s -> RBrace } 120 | "else" @line_space "if" { \s -> Key "elseif" } 121 | @name { \s -> if elem (map toLower s) keywords 122 | then Key (map toLower s) 123 | else ID s } 124 | @data_edit_desc { \s -> DataEditDest s } 125 | @real_literal_constant { \s -> Num s } 126 | 127 | 128 | @binary_constant_prefix { \s -> BinConst s } 129 | @octal_constant_prefix { \s -> OctConst s } 130 | @hex_constant_prefix { \s -> HexConst s } 131 | @binary_constant_suffix { \s -> BinConst s } 132 | @octal_constant_suffix { \s -> OctConst s } 133 | @hex_constant_suffix { \s -> HexConst s } 134 | @digit_string { \s -> Num s } 135 | "go" $white "to" { \s -> Key "goto" } 136 | "GO" $white "TO" { \s -> Key "goto" } 137 | 138 | { 139 | -- Each action has type :: String -> Token 140 | 141 | -- Fixes continuation lines in the middle of strings - removes the continuation line part 142 | cutOutContLine cs = [head cs] ++ (reverse (cutOut cs' (Just []))) ++ [head cs] 143 | where cs' = (take (length cs - 2) (drop 1 cs)) 144 | 145 | cutOut [] Nothing = [] 146 | cutOut [] (Just xs) = xs 147 | cutOut ('&':cs) Nothing = cutOut cs (Just []) 148 | cutOut ('$':cs) Nothing = cutOut cs (Just []) 149 | cutOut ('+':cs) Nothing = cutOut cs (Just []) 150 | cutOut (' ':cs) Nothing = cutOut cs Nothing 151 | cutOut ('\t':cs) Nothing = cutOut cs Nothing 152 | cutOut ('\r':'\n':cs) (Just xs) = (cutOut cs Nothing) ++ xs 153 | cutOut ('\n':cs) (Just xs) = (cutOut cs Nothing) ++ xs 154 | cutOut (c:cs) (Just xs) = cutOut cs (Just (c:xs)) 155 | 156 | 157 | -- The token type: 158 | data Token = Key String | LitConst Char String | OpPower | OpMul | OpDiv | OpAdd | OpSub | OpConcat 159 | | OpEQ | OpNE | OpLT | OpLE | OpGT | OpGE | OpLG 160 | | OpNOT | OpAND | OpOR | OpXOR | OpEQV | OpNEQV 161 | | BinConst String | OctConst String | HexConst String 162 | | ID String | Num String | Comma | Bang | Percent 163 | | LParen | RParen | LArrCon | RArrCon | OpEquals | RealConst String | StopParamStart 164 | | SingleQuote | StrConst String | Period | Colon | ColonColon | SemiColon 165 | | DataEditDest String | Arrow | MArrow | TrueConst | FalseConst | Dollar 166 | | Hash | LBrace | RBrace | NewLine | TokEOF | Text String | ContLine | ContLineAlt | ContLineWithComment | ContLineNoNewLine 167 | deriving (Eq,Show) 168 | 169 | -- all reserved keywords, names are matched against these to see 170 | -- if they are keywords or IDs 171 | keywords :: [String] 172 | keywords = ["allocate", "allocatable","assign", 173 | "assignment","automatic","backspace","block","call", "case", 174 | "character","close","common","complex","contains","continue","cycle", 175 | "data","deallocate","default","dimension","do", 176 | "double","elemental","else","elseif","elsewhere","end", "enddo", "endif", "endfile","entry", 177 | "equivalence","exit","external", 178 | "forall","format","function","goto","iolength", 179 | "if","implicit","in","include","inout","integer","intent","interface", 180 | "intrinsic","inquire","kind","len","logical","module", 181 | "namelist","none","nullify", 182 | "only","open","operator","optional","out","parameter", 183 | "pause","pointer","precision","print","private","procedure", 184 | "program","public","pure","real","read","recursive","result", 185 | "return","rewind","save","select","sequence","sometype","sqrt","stat", 186 | "stop","subroutine","target","to","then","type", 187 | "unit", "use","volatile","where","while","write"] 188 | 189 | {- old keywords, many will be removed 190 | keywords :: [String] 191 | keywords = ["access","action","advance","allocate","allocatable","assign", 192 | "assignment","automatic","backspace","blank","block","call","case", 193 | "character","close","common","complex","contains","continue","cycle", 194 | "data","deallocate","default","delim","dimension","direct","do", 195 | "double","elemental","else","elseif","elsewhere","end", "enddo", "endif", "endfile","entry", 196 | "eor","err","equivalence","exist","exit","external","file","fmt", 197 | "forall","form","format","formatted","function","goto","iostat","iolength", 198 | "if","implicit","in","inout","integer","intent","interface", 199 | "intrinsic","inquire","kind","len","logical","module","number", 200 | "named","nml","nextrec","namelist","none","nullify","null()", 201 | "only","open","opened","operator","optional","out","pad","parameter", 202 | "pause","pointer","position","precision","print","private","procedure", 203 | "program","pure","real","read","readwrite","rec","recl","recursive","result", 204 | "return","rewind","save","select","sequence","sequential","sometype","stat", 205 | "status","stop","subroutine","target","to","then","type","unformatted", 206 | "unit","use","volatile","where","while","write"] 207 | -} 208 | 209 | lexer :: (Token -> P a) -> P a 210 | lexer = runL lexer' 211 | 212 | lexer' :: Lex a Token 213 | lexer' = do s <- getInput 214 | startToken 215 | case alexScan ('\0',[],s) 0 of 216 | AlexEOF -> return TokEOF 217 | AlexError (c,b,s') -> getInput >>= (\i -> fail ("unrecognizable token: " ++ show c ++ "(" ++ (show $ ord c) ++ "). ")) 218 | AlexSkip (_,b,s') len -> discard len >> lexer' 219 | AlexToken (_,b,s') len act -> do let tok = act (take len s) 220 | -- turn on for useful debugging info on lexing 221 | -- (show (tok, (take 20 s), len) ++ "\n") `trace` return () 222 | case tok of 223 | NewLine -> lexNewline >> (return tok) 224 | ContLine -> (discard (len - 1)) >> lexNewline >> lexer' 225 | ContLineNoNewLine -> (discard len) >> lexer' 226 | ContLineAlt -> lexNewline >> (discard (len - 1)) >> lexer' 227 | ContLineWithComment -> lexNewline >> lexNewline >> (discard (len - 2)) >> lexer' 228 | _ -> (discard len) >> (return tok) 229 | } 230 | -------------------------------------------------------------------------------- /src/Language/Fortran/Parser.y: -------------------------------------------------------------------------------- 1 | { 2 | module Language.Fortran.Parser ( 3 | parser 4 | , include_parser 5 | -- * Helpers 6 | , fst3 7 | , snd3 8 | , trd3 9 | , fst4 10 | , snd4 11 | , trd4 12 | , frh4 13 | ) 14 | where 15 | 16 | import Language.Fortran 17 | import Language.Fortran.PreProcess 18 | 19 | import qualified Language.Haskell.Syntax as LH (SrcLoc(..)) 20 | import Language.Haskell.ParseMonad 21 | import Language.Fortran.Lexer 22 | import Data.Char (toLower) 23 | import Debug.Trace 24 | 25 | } 26 | 27 | %name parser executable_program 28 | %name include_parser include_program 29 | %tokentype { Token } 30 | 31 | %monad { P } { >>= } { return } 32 | %lexer { lexer } { TokEOF } 33 | 34 | %token 35 | '=>' { Arrow } 36 | '**' { OpPower } 37 | '//' { OpConcat } 38 | '==' { OpEQ } 39 | '/=' { OpNE } 40 | '<=' { OpLE } 41 | '>=' { OpGE } 42 | '.NOT.' { OpNOT } 43 | '.AND.' { OpAND } 44 | '.OR.' { OpOR } 45 | '.TRUE.' { TrueConst } 46 | '.FALSE.' { FalseConst } 47 | -- '.EQV.' { OpEQV } 48 | -- '.NEGV.' { OpNEQV } 49 | '<' { OpLT } 50 | '>' { OpGT } 51 | '*' { OpMul } 52 | '/' { OpDiv } 53 | '+' { OpAdd } 54 | '-' { OpSub } 55 | ',' { Comma } 56 | '(' { LParen } 57 | ')' { RParen } 58 | '=' { OpEquals } 59 | -- '\'' { SingleQuote } 60 | -- '\"' { DoubleQuote } 61 | '.' { Period } 62 | '::' { ColonColon } 63 | ':' { Colon } 64 | ';' { SemiColon } 65 | '#' { Hash } 66 | '{' { LBrace } 67 | '}' { RBrace } 68 | '(/' { LArrCon } 69 | '/)' { RArrCon } 70 | DATA_DESC { DataEditDest $$ } 71 | --'b' { LitMark $$ } 72 | --'B' { LitMark $$ } 73 | --'z' { LitMark $$ } 74 | --'Z' { LitMark $$ } 75 | --'o' { LitMark $$ } 76 | --'O' { LitMark $$ } 77 | -- OBSOLETE '!' { Bang } 78 | '%' { Percent } 79 | '$' { Dollar } 80 | -- OBSOLETE '!{' { StopParamStart } 81 | '\n' { NewLine } 82 | ALLOCATE { Key "allocate" } 83 | ALLOCATABLE { Key "allocatable" } 84 | ASSIGN { Key "Assign" } 85 | ASSIGNMENT { Key "assignment" } 86 | -- AUTOMATIC { Key "automatic" } 87 | BACKSPACE { Key "backspace" } 88 | BLOCK { Key "block" } 89 | CALL { Key "call" } 90 | -- CASE { Key "case" } 91 | CHARACTER { Key "character" } 92 | CLOSE { Key "close" } 93 | COMMON { Key "common" } 94 | COMPLEX { Key "complex" } 95 | CONTAINS { Key "contains" } 96 | CONTINUE { Key "continue" } 97 | CYCLE { Key "cycle" } 98 | DATA { Key "data" } 99 | DEALLOCATE { Key "deallocate" } 100 | -- DEFAULT { Key "default" } 101 | DIMENSION { Key "dimension" } 102 | DO { Key "do" } 103 | -- DOUBLE { Key "double" } 104 | ELEMENTAL { Key "elemental" } 105 | ELSE { Key "else" } 106 | ELSEIF { Key "elseif" } 107 | ELSEWHERE { Key "elsewhere" } 108 | END { Key "end" } 109 | ENDIF { Key "endif" } 110 | ENDDO { Key "enddo" } 111 | ENDFILE { Key "endfile" } 112 | -- ENTRY { Key "entry" } 113 | EQUIVALENCE { Key "equivalence" } 114 | EXIT { Key "exit" } 115 | EXTERNAL { Key "external" } 116 | FORALL { Key "forall" } 117 | FOREACH { Key "foreach" } 118 | FORMAT { Key "format" } 119 | FUNCTION { Key "function" } 120 | GOTO { Key "goto" } 121 | IOLENGTH { Key "iolength" } 122 | IF { Key "if" } 123 | IMPLICIT { Key "implicit" } 124 | IN { Key "in" } 125 | INCLUDE { Key "include" } 126 | INOUT { Key "inout" } 127 | INTEGER { Key "integer" } 128 | INTENT { Key "intent" } 129 | INTERFACE { Key "interface" } 130 | INTRINSIC { Key "intrinsic" } 131 | INQUIRE { Key "inquire" } 132 | KIND { Key "kind" } 133 | LEN { Key "len" } 134 | LOGICAL { Key "logical" } 135 | MODULE { Key "module" } 136 | NAMELIST { Key "namelist" } 137 | NONE { Key "none" } 138 | NULLIFY { Key "nullify" } 139 | NULL { Key "null" } 140 | -- ONLY { Key "only" } 141 | OPEN { Key "open" } 142 | OPERATOR { Key "operator" } 143 | OPTIONAL { Key "optional" } 144 | OUT { Key "out" } 145 | PARAMETER { Key "parameter" } 146 | PAUSE { Key "pause" } 147 | POINTER { Key "pointer" } 148 | -- PRECISION { Key "precision" } 149 | PRINT { Key "print" } 150 | PRIVATE { Key "private" } 151 | PROCEDURE { Key "procedure" } 152 | PROGRAM { Key "program" } 153 | PURE { Key "pure" } 154 | PUBLIC { Key "public" } 155 | REAL { Key "real" } 156 | READ { Key "read" } 157 | RECURSIVE { Key "recursive" } 158 | RESULT { Key "result" } 159 | RETURN { Key "return" } 160 | REWIND { Key "rewind" } 161 | SAVE { Key "save" } 162 | -- SELECT { Key "select" } 163 | SEQUENCE { Key "sequence" } 164 | -- SIZE { Key "size" } 165 | SOMETYPE { Key "sometype" } 166 | SQRT { Key "sqrt" } 167 | STAT { Key "stat" } 168 | STOP { Key "stop" } 169 | STR { StrConst $$ } 170 | ZLIT { LitConst 'z' $$ } 171 | SUBROUTINE { Key "subroutine" } 172 | TARGET { Key "target" } 173 | -- TO { Key "to" } 174 | THEN { Key "then" } 175 | TYPE { Key "type" } 176 | -- UNFORMATED { Key "unformatted" } 177 | UNIT { Key "unit" } -- units-of-measure extension 178 | '1' { Num "1" } -- units-of-measure extension 179 | USE { Key "use" } 180 | VOLATILE { Key "volatile" } 181 | WHILE { Key "while" } 182 | WHERE { Key "where" } 183 | WRITE { Key "write" } 184 | ID { ID $$ } 185 | NUM { Num $$ } 186 | LABEL { Num $$ } 187 | TEXT { Text $$ } 188 | %% 189 | 190 | include_program :: { Program A0 } 191 | include_program 192 | : srcloc newline specification_part_top {% do { s <- getSrcSpan $1; 193 | return [IncludeProg () s $3 Nothing] }} 194 | 195 | executable_program :: { Program A0 } 196 | executable_program 197 | : program_unit_list { $1 } 198 | 199 | program_unit_list :: { Program A0 } 200 | program_unit_list 201 | : program_unit_list newline0 program_unit { $1++[$3] } 202 | | {- empty -} { [] } 203 | 204 | program_unit :: { ProgUnit A0 } 205 | program_unit 206 | : main_program { $1 } 207 | | external_subprogram { $1 } 208 | | module { $1 } 209 | | block_data { $1 } 210 | 211 | plist :: { [String] } 212 | plist 213 | : plist ',' id2 { $1++[$3] } 214 | | id2 { [$1] } 215 | 216 | vlist :: { [Expr A0] } 217 | vlist 218 | : variable ',' vlist { $1:$3 } 219 | | variable { [$1] } 220 | 221 | newline :: {} 222 | newline : '\n' newline0 {} 223 | -- | ';' newline0 {} 224 | 225 | newline0 :: {} 226 | newline0 : newline {} 227 | | {- empty -} {} 228 | 229 | main_program :: { ProgUnit A0 } 230 | main_program 231 | : srcloc program_stmt srcloc use_stmt_list implicit_part srcloc specification_part_top execution_part module_subprogram_part end_program_stmt newline0 232 | {% do { s <- getSrcSpan $1; 233 | s' <- getSrcSpan $6; 234 | name <- cmpNames (fst $2) $10 "program"; 235 | return (Main () s name (snd $2) (Block () (UseBlock $4 $3) $5 s' $7 $8) $9); } } 236 | 237 | 238 | 239 | program_stmt :: { (SubName A0, Arg A0) } 240 | program_stmt 241 | : PROGRAM subname args_p newline { ($2, $3) } 242 | | PROGRAM subname srcloc newline { ($2, (Arg () (NullArg ())) ($3, $3)) } 243 | 244 | end_program_stmt :: { String } 245 | end_program_stmt 246 | : END PROGRAM id2 { $3 } 247 | | END PROGRAM { "" } 248 | | END { "" } 249 | 250 | implicit_part :: { Implicit A0 } 251 | implicit_part 252 | : IMPLICIT NONE newline { ImplicitNone () } 253 | | {- empty -} { ImplicitNull () } 254 | 255 | external_subprogram :: { ProgUnit A0} 256 | external_subprogram 257 | : function_subprogram { $1 } 258 | | subroutine_subprogram { $1 } 259 | 260 | subroutine_subprogram :: { ProgUnit A0 } 261 | subroutine_subprogram 262 | : srcloc subroutine_stmt srcloc use_stmt_list implicit_part srcloc specification_part_top execution_part end_subroutine_stmt newline0 263 | {% do { s <- getSrcSpan $1; 264 | s' <- getSrcSpan $6; 265 | name <- cmpNames (fst3 $2) $9 "subroutine"; 266 | return (Sub () s (trd3 $2) name (snd3 $2) (Block () (UseBlock $4 $3) $5 s' $7 $8)); } } 267 | 268 | end_subroutine_stmt :: { String } 269 | end_subroutine_stmt 270 | : END SUBROUTINE id2 { $3 } 271 | | END SUBROUTINE { "" } 272 | | END { "" } 273 | 274 | end_function_stmt :: { String } 275 | end_function_stmt 276 | : END FUNCTION id2 { $3 } 277 | | END FUNCTION { "" } 278 | | END { "" } 279 | 280 | function_subprogram :: { ProgUnit A0 } 281 | function_subprogram 282 | : srcloc function_stmt srcloc use_stmt_list implicit_part srcloc specification_part_top execution_part end_function_stmt newline0 {% do { s <- getSrcSpan $1; 283 | s' <- getSrcSpan $6; 284 | name <- cmpNames (fst4 $2) $9 "function"; 285 | return (Function () s (trd4 $2) name (snd4 $2) (frh4 $2) (Block () (UseBlock $4 $3) $5 s' $7 $8)); } } 286 | 287 | block_data :: { ProgUnit A0 } 288 | block_data 289 | : srcloc block_data_stmt use_stmt_list implicit_part specification_part_top end_block_data_stmt 290 | {% do { s <- getSrcSpan $1; 291 | name <- cmpNames $2 $6 "block data"; 292 | return (BlockData () s name $3 $4 $5); } } 293 | 294 | block_data_stmt :: { SubName A0 } 295 | block_data_stmt 296 | : BLOCK DATA subname { $3 } 297 | | BLOCK DATA { "foobar" `trace` NullSubName () } 298 | 299 | end_block_data_stmt :: { String } 300 | end_block_data_stmt 301 | : END BLOCK DATA id2 { $4 } 302 | | END BLOCK DATA { "" } 303 | | END { "" } 304 | 305 | module :: { ProgUnit A0 } 306 | module 307 | : srcloc module_stmt use_stmt_list implicit_part specification_part_top module_subprogram_part end_module_stmt newline0 308 | {% do { s <- getSrcSpan $1; 309 | name <- cmpNames $2 $7 "module"; 310 | return (Module () s name $3 $4 $5 $6); } } 311 | 312 | module_stmt :: { SubName A0 } 313 | module_stmt 314 | : MODULE subname newline { $2 } 315 | 316 | end_module_stmt :: { String } 317 | end_module_stmt 318 | : END MODULE id2 { $3 } 319 | | END MODULE { "" } 320 | | END { "" } 321 | 322 | module_subprogram_part :: { Program A0 } 323 | module_subprogram_part 324 | : CONTAINS newline internal_subprogram_list { $3 } 325 | | {- empty -} { [] } 326 | 327 | internal_subprogram_list :: { Program A0 } 328 | internal_subprogram_list 329 | : internal_subprogram_list internal_subprogram newline0 { $1++[$2] } 330 | | {- empty -} { [] } 331 | 332 | internal_subprogram :: { ProgUnit A0 } 333 | internal_subprogram 334 | : subroutine_subprogram { $1 } 335 | | function_subprogram { $1 } 336 | 337 | use_stmt_list :: { Uses A0 } 338 | use_stmt_list 339 | : use_stmt use_stmt_list { Use () $1 $2 () } 340 | | {- empty -} { UseNil () } 341 | 342 | use_stmt :: { (String, Renames) } 343 | use_stmt 344 | : USE id2 newline { ($2, []) } 345 | | USE COMMON ',' renames newline { ("common", $4) } -- Since "common" is a valid module name 346 | | USE id2 ',' renames newline { ($2, $4) } 347 | 348 | renames :: { [(Variable, Variable)] } 349 | : id2 '=>' id2 { [($1, $3)] } 350 | | renames ',' renames { $1 ++ $3 } 351 | 352 | 353 | -- [DO: Allows the specification part of a module to be empty] 354 | specification_part_top :: { Decl A0 } 355 | specification_part_top 356 | : specification_part { $1 } 357 | | {- empty -} {% getSrcSpanNull >>= (\s -> return $ NullDecl () s)} 358 | 359 | specification_part :: { Decl A0 } 360 | specification_part 361 | : declaration_construct_l specification_part { DSeq () $1 $2 } 362 | | declaration_construct_l { $1 } 363 | 364 | 365 | declaration_construct_l :: { Decl A0 } 366 | declaration_construct_l 367 | : declaration_construct_p newline { $1 } 368 | 369 | declaration_construct_p :: { Decl A0 } 370 | declaration_construct_p 371 | : declaration_construct { $1 } 372 | | specification_stmt { $1 } 373 | | derived_type_def { $1 } 374 | | TEXT { TextDecl () $1 } 375 | 376 | -- Not sure about the ArrayT outputs here, think this may be a bug 377 | 378 | declaration_construct :: { Decl A0 } 379 | declaration_construct 380 | : srcloc type_spec_p attr_spec_list '::' entity_decl_list 381 | {% (getSrcSpan $1) >>= (\s -> return $ if null (fst $3) 382 | then Decl () s $5 ((BaseType () (fst3 $2) (snd $3) (snd3 $2) (trd3 $2))) 383 | else Decl () s $5 ((ArrayT () (fst $3) (fst3 $2) (snd $3) (snd3 $2) (trd3 $2)))) } 384 | | srcloc type_spec_p attr_spec_list entity_decl_list 385 | {% (getSrcSpan $1) >>= (\s -> return $ if null (fst $3) 386 | then Decl () s $4 ((BaseType () (fst3 $2) (snd $3) (snd3 $2) (trd3 $2))) 387 | else Decl () s $4 ((ArrayT () (fst $3) (fst3 $2) (snd $3) (snd3 $2) (trd3 $2)))) } 388 | | interface_block { $1 } 389 | | include_stmt { $1 } 390 | 391 | 392 | attr_spec_list :: {([(Expr A0, Expr A0)],[Attr A0])} 393 | attr_spec_list 394 | : attr_spec_list ',' attr_spec { (fst $1++fst $3,snd $1++snd $3) } 395 | | {- empty -} { ([],[]) } 396 | 397 | entity_decl_list :: { [(Expr A0, Expr A0, Maybe Int)] } 398 | entity_decl_list 399 | : entity_decl ',' entity_decl_list { $1:$3 } 400 | | entity_decl { [$1] } 401 | 402 | entity_decl :: { (Expr A0, Expr A0, Maybe Int) } 403 | entity_decl 404 | -- : srcloc ID '=' expr {% getSrcSpan $1 >>= (\s -> return $ (Var () s [(VarName () $2,[])], $4, Nothing)) } 405 | : variable '=' expr { ($1, $3, Nothing) } 406 | | variable {% getSrcSpanNull >>= (\s -> return $ ($1, NullExpr () s, Nothing)) } 407 | | variable '*' num {% getSrcSpanNull >>= (\s -> return $ ($1, NullExpr () s, Just $ read $3)) } 408 | 409 | -- | id2 {% getSrcSpanNull >>= (\s -> return $ (Var () s [(VarName () $1,[])], NullExpr () s, Nothing)) } 410 | 411 | 412 | object_name :: { String } 413 | object_name 414 | : id2 { $1 } 415 | 416 | type_spec_p :: { (BaseType A0, Expr A0, Expr A0) } 417 | type_spec_p 418 | : type_spec { (fst3 $1, snd3 $1, trd3 $1) } 419 | 420 | type_spec :: { (BaseType A0, Expr A0, Expr A0) } 421 | type_spec 422 | : INTEGER kind_selector {% getSrcSpanNull >>= (\s -> return $ (Integer (), $2, NullExpr () s)) } 423 | | INTEGER '*' length_value {% getSrcSpanNull >>= (\s -> return $ (Integer (), $3, NullExpr () s)) } 424 | | INTEGER {% getSrcSpanNull >>= (\s -> return $ (Integer (), NullExpr () s, NullExpr () s)) } 425 | | REAL kind_selector {% getSrcSpanNull >>= (\s -> return $ (Real (), $2, NullExpr () s)) } 426 | | REAL '*' length_value {% getSrcSpanNull >>= (\s -> return $ (Real (), $3, NullExpr () s)) } 427 | | REAL {% getSrcSpanNull >>= (\s -> return $ (Real (), NullExpr () s, NullExpr () s)) } 428 | | SOMETYPE {% getSrcSpanNull >>= (\s -> return $ (SomeType (), NullExpr () s, NullExpr () s)) } 429 | -- | DOUBLE PRECISION kind_selector { (Double (), $3, ne s)) } 430 | -- | DOUBLE PRECISION '*' length_value { (Double (), $4, ne s)) } 431 | -- | DOUBLE PRECISION { (Double (), ne s, ne s)) } 432 | | COMPLEX kind_selector {% getSrcSpanNull >>= (\s -> return $ (Complex (), $2, NullExpr () s)) } 433 | | COMPLEX '*' length_value {% getSrcSpanNull >>= (\s -> return $ (Complex (), $3, NullExpr () s)) } 434 | | COMPLEX {% getSrcSpanNull >>= (\s -> return $ (Complex (),NullExpr () s, NullExpr () s)) } 435 | | CHARACTER char_selector { (Character (), snd $2, fst $2) } 436 | | CHARACTER '*' length_value {% getSrcSpanNull >>= (\s -> return $ (Character (), $3, NullExpr () s)) } 437 | | CHARACTER {% getSrcSpanNull >>= (\s -> return $ (Character (), NullExpr () s, NullExpr () s)) } 438 | | LOGICAL kind_selector {% getSrcSpanNull >>= (\s -> return $ (Logical (), $2, NullExpr () s)) } 439 | | LOGICAL '*' length_value {% getSrcSpanNull >>= (\s -> return $ (Logical (), $3, NullExpr () s)) } 440 | | LOGICAL {% getSrcSpanNull >>= (\s -> return $ (Logical (), NullExpr () s, NullExpr () s)) } 441 | | TYPE '(' type_name ')' {% getSrcSpanNull >>= (\s -> return $ (DerivedType () $3, NullExpr () s, NullExpr () s)) } 442 | 443 | -- | POINTER '(' pointer_name ',' pointee_name ['(' array_spec ')' ] ')' 444 | --[',' '(' pointer_name ',' pointee_name ['(' array_spec ')' ] ')' ] 445 | 446 | kind_selector :: { Expr A0 } 447 | : '(' KIND '=' expr ')' { $4 } 448 | | '(' expr ')' { $2 } 449 | 450 | char_selector :: { (Expr A0, Expr A0) } -- (LEN, KIND) 451 | char_selector 452 | : length_selector {% getSrcSpanNull >>= (\s -> return $ ($1,NullExpr () s)) } 453 | | '(' LEN '=' char_len_param_value ',' KIND '=' expr ')' { ($4,$8) } 454 | | '(' char_len_param_value ',' KIND '=' expr ')' { ($2,$6) } 455 | | '(' char_len_param_value ',' expr ')' {% getSrcSpanNull >>= (\s -> return $ ($2,NullExpr () s)) } 456 | | '(' KIND '=' expr ',' LEN '=' char_len_param_value ')' { ($8,$4) } 457 | | '(' KIND '=' expr ')' {% getSrcSpanNull >>= (\s -> return $ (NullExpr () s,$4)) } 458 | 459 | length_selector :: { Expr A0 } 460 | length_selector 461 | : '(' LEN '=' char_len_param_value ')' { $4 } 462 | | '(' char_len_param_value ')' { $2 } 463 | 464 | char_len_param_value :: { Expr A0 } 465 | char_len_param_value 466 | : specification_expr { $1 } 467 | | srcloc '*' {% getSrcSpan $1 >>= (\s -> return $ Con () s "*") } 468 | 469 | length_value :: { Expr A0 } 470 | length_value 471 | : srcloc num {% getSrcSpan $1 >>= (\s -> return $ Con () s $2) } 472 | 473 | dim_spec :: { [(Expr A0, Expr A0)] } 474 | dim_spec 475 | : DIMENSION '(' array_spec ')' { $3 } 476 | | DIMENSION '(' ')' { [] } -- modified by Zhe on 11/14/2004 477 | 478 | dim_spec_p :: { [(Expr A0, Expr A0)] } 479 | dim_spec_p 480 | : DIMENSION array_spec { $2 } 481 | 482 | attr_spec_p :: { ([(Expr A0, Expr A0)],[Attr A0]) } 483 | attr_spec_p : 484 | PARAMETER { ([],[Parameter ()]) } 485 | | access_spec { ([],[$1]) } 486 | | ALLOCATABLE { ([],[Allocatable ()]) } 487 | | EXTERNAL { ([],[External ()]) } 488 | | INTENT '(' intent_spec ')' { ([],[Intent () $3]) } 489 | | INTRINSIC { ([],[Intrinsic ()]) } 490 | | OPTIONAL { ([],[Optional ()]) } 491 | | POINTER { ([],[Pointer ()]) } 492 | | SAVE { ([],[Save ()]) } 493 | | TARGET { ([],[Target ()]) } 494 | | UNIT '(' unit_spec ')' { ([],[MeasureUnit () $3]) } -- units-of-measure 495 | | VOLATILE { ([],[Volatile ()]) } 496 | 497 | attr_spec :: { ([(Expr A0, Expr A0)],[Attr A0]) } 498 | attr_spec 499 | : dim_spec { ([],[Dimension () $1]) } 500 | | PARAMETER { ([],[Parameter ()]) } 501 | | access_spec { ([],[$1]) } 502 | | ALLOCATABLE { ([],[Allocatable ()]) } 503 | | EXTERNAL { ([],[External ()]) } 504 | | INTENT '(' intent_spec ')' { ([],[Intent () $3]) } 505 | | INTRINSIC { ([],[Intrinsic ()]) } 506 | | OPTIONAL { ([],[Optional ()]) } 507 | | POINTER { ([],[Pointer ()]) } 508 | | SAVE { ([],[Save ()]) } 509 | | TARGET { ([],[Target ()]) } 510 | | UNIT '(' unit_spec ')' { ([],[MeasureUnit () $3]) } 511 | | VOLATILE { ([],[Volatile ()]) } 512 | 513 | access_spec :: { Attr A0 } 514 | access_spec 515 | : PUBLIC { Public () } 516 | | PRIVATE { Private () } 517 | 518 | -- start: units-of-measure extension parsing 519 | 520 | unit_stmt :: { Decl A0 } 521 | : UNIT '::' unit_decl_list {% getSrcSpanNull >>= (\s -> return $ MeasureUnitDef () s $3) } 522 | 523 | unit_decl_list :: { [(MeasureUnit, MeasureUnitSpec A0)] } 524 | unit_decl_list 525 | : unit_decl ',' unit_decl_list { $1:$3 } 526 | | unit_decl { [$1] } 527 | 528 | unit_decl :: { (MeasureUnit, MeasureUnitSpec A0) } 529 | unit_decl 530 | : srcloc ID '=' unit_spec {% getSrcSpan $1 >>= (\s -> return ($2, $4)) } 531 | 532 | unit_spec :: { MeasureUnitSpec A0 } 533 | unit_spec 534 | : mult_unit_spec '/' mult_unit_spec { UnitQuotient () $1 $3 } 535 | | mult_unit_spec { UnitProduct () $1 } 536 | | {- empty -} { UnitNone () } 537 | 538 | mult_unit_spec :: { [(MeasureUnit, Fraction A0)] } 539 | mult_unit_spec 540 | : mult_unit_spec power_unit_spec { $1++$2 } 541 | | power_unit_spec { $1 } 542 | 543 | power_unit_spec :: { [(MeasureUnit, Fraction A0)] } 544 | power_unit_spec 545 | : ID '**' power_spec { [($1, $3)] } 546 | | ID { [($1, NullFraction ())] } 547 | | '1' { [] } 548 | 549 | power_spec :: { Fraction A0 } 550 | power_spec 551 | : '(' signed_num '/' signed_num ')' { FractionConst () $2 $4 } 552 | | signed_num { IntegerConst () $1 } 553 | | '(' power_spec ')' { $2 } 554 | 555 | signed_num :: { String } 556 | signed_num 557 | : '-' num { "-" ++ $2 } 558 | | num { $1 } 559 | 560 | -- end 561 | 562 | array_spec :: { [(Expr A0, Expr A0)] } 563 | array_spec 564 | : explicit_shape_spec_list { map expr2array_spec $1 } 565 | 566 | explicit_shape_spec_list :: { [Expr A0] } 567 | explicit_shape_spec_list 568 | : explicit_shape_spec_list ',' explicit_shape_spec {$1++[$3]} 569 | | explicit_shape_spec {[$1]} 570 | 571 | explicit_shape_spec :: { Expr A0 } 572 | explicit_shape_spec 573 | : expr { $1 } 574 | | bound { $1 } 575 | 576 | include_stmt :: { Decl A0 } 577 | : INCLUDE srcloc STR {% getSrcSpan $2 >>= (\s -> return $ Include () (Con () s $3)) } 578 | 579 | specification_expr :: { Expr A0 } 580 | specification_expr 581 | : expr { $1 } 582 | 583 | intent_spec :: { IntentAttr A0 } 584 | intent_spec 585 | : IN { In () } 586 | | OUT { Out () } 587 | | INOUT { InOut () } 588 | 589 | specification_stmt :: { Decl A0 } 590 | specification_stmt 591 | : access_stmt { $1 } 592 | | attr_stmt { $1 } 593 | | unit_stmt { $1 } 594 | -- | allocatable_stmt { $1 } 595 | | common_stmt { $1 } 596 | | data_stmt { DataDecl () $1 } 597 | | equivalence_stmt { $1 } 598 | -- | dimension_stmt { $1 } 599 | | external_stmt { $1 } 600 | -- | intent_stmt { $1 } 601 | -- | intrinsic_stmt { $1 } 602 | | namelist_stmt { $1 } 603 | -- | optional_stmt { $1 } 604 | -- | pointer_stmt { $1 } 605 | | save_stmt { $1 } 606 | -- | target_stmt { $1 } 607 | 608 | save_stmt :: { Decl A0 } 609 | : SAVE { AccessStmt () (Save ()) [] } 610 | 611 | common_stmt :: { Decl A0 } 612 | : srcloc COMMON '/' id2 '/' vlist {% getSrcSpan $1 >>= (\s -> return $ Common () s (Just $4) $6) } 613 | | srcloc COMMON vlist {% getSrcSpan $1 >>= (\s -> return $ Common () s Nothing $3) } 614 | 615 | 616 | interface_block :: { Decl A0 } 617 | interface_block 618 | : interface_stmt newline interface_spec_list newline end_interface_stmt { Interface () $1 $3 } 619 | 620 | interface_stmt :: { Maybe (GSpec A0) } 621 | interface_stmt 622 | : INTERFACE generic_spec { Just $2 } 623 | | INTERFACE { Nothing } 624 | 625 | interface_spec_list :: { [InterfaceSpec A0] } 626 | interface_spec_list 627 | : interface_spec_list interface_spec { $1++[$2] } 628 | | interface_spec { [$1] } 629 | 630 | interface_spec :: { InterfaceSpec A0 } 631 | interface_spec 632 | : interface_body { $1 } 633 | | module_procedure_stmt { $1 } 634 | 635 | end_interface_stmt :: { Maybe (GSpec A0) } 636 | end_interface_stmt 637 | : END INTERFACE generic_spec { Just $3 } 638 | | END INTERFACE { Nothing } 639 | 640 | interface_body :: { InterfaceSpec A0 } 641 | interface_body 642 | : function_stmt use_stmt_list implicit_part specification_part end_function_stmt 643 | {% do { name <- cmpNames (fst4 $1) $5 "interface declaration"; 644 | return (FunctionInterface () name (snd4 $1) $2 $3 $4); }} 645 | 646 | | function_stmt end_function_stmt 647 | {% do { name <- cmpNames (fst4 $1) $2 "interface declaration"; 648 | s <- getSrcSpanNull; 649 | return (FunctionInterface () name (snd4 $1) (UseNil ()) (ImplicitNull ()) (NullDecl () s)); } } 650 | 651 | | subroutine_stmt use_stmt_list implicit_part specification_part end_subroutine_stmt 652 | {% do { name <- cmpNames (fst3 $1) $5 "interface declaration"; 653 | return (SubroutineInterface () name (snd3 $1) $2 $3 $4); } } 654 | 655 | | subroutine_stmt end_subroutine_stmt 656 | {% do { name <- cmpNames (fst3 $1) $2 "interface declaration"; 657 | s <- getSrcSpanNull; 658 | return (SubroutineInterface () name (snd3 $1) (UseNil ()) (ImplicitNull ()) (NullDecl () s)); }} 659 | 660 | module_procedure_stmt :: { InterfaceSpec A0 } 661 | module_procedure_stmt 662 | : MODULE PROCEDURE sub_name_list { ModuleProcedure () $3 } 663 | 664 | sub_name_list :: { [SubName A0 ] } 665 | sub_name_list 666 | : sub_name_list ',' subname { $1++[$3] } 667 | | subname { [$1] } 668 | 669 | derived_type_def :: { Decl A0 } 670 | derived_type_def 671 | : srcloc derived_type_stmt private_sequence_stmt component_def_stmt_list end_type_stmt 672 | {% do { sp <- getSrcSpan $1; 673 | name <- cmpNames (fst $2) $5 "derived type name"; 674 | return (DerivedTypeDef () sp name (snd $2) $3 $4); } } 675 | 676 | derived_type_stmt :: { (SubName A0, [Attr A0]) } 677 | derived_type_stmt 678 | : TYPE ',' access_spec '::' type_name { ($5,[$3]) } 679 | | TYPE '::' type_name { ($3,[]) } 680 | | TYPE type_name { ($2,[]) } 681 | 682 | end_type_stmt :: { String } 683 | end_type_stmt 684 | : END TYPE { "" } 685 | | END TYPE id2 { $3 } 686 | 687 | 688 | type_name :: { SubName A0 } 689 | type_name 690 | : ID { SubName () $1 } 691 | 692 | private_sequence_stmt :: { [Attr A0] } 693 | private_sequence_stmt 694 | : PRIVATE SEQUENCE { [Private (), Sequence ()] } 695 | | SEQUENCE PRIVATE { [Sequence (), Private ()] } 696 | | PRIVATE { [Private ()] } 697 | | SEQUENCE { [Sequence ()] } 698 | | {- empty -} { [] } 699 | 700 | component_def_stmt_list :: { [Decl A0 ] } 701 | component_def_stmt_list 702 | : component_def_stmt_list component_def_stmt { $1++[$2] } 703 | | component_def_stmt { [$1] } 704 | 705 | component_def_stmt :: { Decl A0 } 706 | component_def_stmt 707 | : srcloc type_spec_p component_attr_spec_list '::' entity_decl_list 708 | {% (getSrcSpan $1) >>= (\s -> return $ 709 | if null (fst $3) 710 | then Decl () s $5 ((BaseType () (fst3 $2) (snd $3) (snd3 $2) (trd3 $2))) 711 | else Decl () s $5 ((ArrayT () (fst $3) (fst3 $2) (snd $3) (snd3 $2) (trd3 $2)))) } 712 | 713 | component_attr_spec_list :: {([(Expr A0, Expr A0)],[Attr A0])} 714 | component_attr_spec_list 715 | : component_attr_spec_list ',' component_attr_spec { (fst $1++fst $3,snd $1++snd $3) } 716 | | {- empty -} { ([],[]) } 717 | 718 | component_attr_spec :: { ([(Expr A0, Expr A0)],[Attr A0]) } 719 | component_attr_spec 720 | : POINTER { ([],[Pointer ()]) } 721 | | dim_spec { ($1,[]) } 722 | 723 | attr_stmt :: { Decl A0 } 724 | attr_stmt : attr_spec_p '(' entity_decl_list ')' { AttrStmt () (head $ snd $1) ($3 ++ (map (\(x, y) -> (x, y, Nothing)) (fst $1))) } 725 | | attr_spec_p { AttrStmt () (head $ snd $1) ((map (\(x, y) -> (x, y, Nothing)) (fst $1))) } 726 | | dim_spec_p { AttrStmt () (Dimension () $1) [] } 727 | 728 | access_stmt :: { Decl A0 } 729 | access_stmt 730 | : access_spec '::' access_id_list { AccessStmt () $1 $3 } 731 | | access_spec access_id_list { AccessStmt () $1 $2 } 732 | | access_spec { AccessStmt () $1 [] } 733 | 734 | access_id_list :: { [GSpec A0] } 735 | access_id_list 736 | : access_id_list ',' access_id { $1++[$3] } 737 | | access_id { [$1] } 738 | 739 | access_id :: { GSpec A0 } 740 | access_id 741 | : generic_spec { $1 } 742 | 743 | generic_spec :: { GSpec A0 } 744 | generic_spec 745 | : srcloc ID {% getSrcSpan $1 >>= (\s -> return $ GName () (Var () s [(VarName () $2,[])])) } 746 | | OPERATOR '(' defined_operator ')' { GOper () $3 } 747 | | ASSIGNMENT '(' '=' ')' { GAssg () } 748 | 749 | data_stmt :: { DataForm A0 } 750 | data_stmt 751 | : DATA data_stmt_set_list { Data () $2 } 752 | 753 | data_stmt_set_list :: { [(Expr A0, Expr A0)] } 754 | data_stmt_set_list 755 | : data_stmt_set_list ',' data_stmt_set { $1++[$3] } 756 | | data_stmt_set { [$1] } 757 | 758 | data_stmt_set :: { (Expr A0, Expr A0) } 759 | data_stmt_set 760 | : data_stmt_object_list '/' data_stmt_value_list '/' { ($1,$3) } 761 | 762 | data_stmt_object_list :: { Expr A0 } 763 | data_stmt_object_list 764 | : data_stmt_object_list ',' data_stmt_object { ESeq () (spanTrans $1 $3) $1 $3 } 765 | | data_stmt_object { $1 } 766 | 767 | data_stmt_object :: { Expr A0 } 768 | data_stmt_object 769 | : variable { $1 } 770 | 771 | 772 | data_stmt_value_list :: { Expr A0 } 773 | data_stmt_value_list 774 | : data_stmt_value_list ',' data_stmt_value { ESeq () (spanTrans $1 $3) $1 $3 } 775 | | data_stmt_value { $1 } 776 | 777 | data_stmt_value :: { Expr A0 } 778 | data_stmt_value 779 | : primaryP { $1 } 780 | 781 | 782 | external_stmt :: { Decl A0 } 783 | external_stmt 784 | : EXTERNAL '::' name_list { ExternalStmt () $3 } 785 | | EXTERNAL name_list { ExternalStmt () $2 } 786 | 787 | name_list :: { [String] } 788 | name_list 789 | : name_list ',' id2 { $1++[$3] } 790 | | id2 { [$1] } 791 | 792 | id2 :: { String } -- hack len 793 | id2 : ID { $1 } 794 | | id_keywords { $1 } 795 | 796 | id_keywords :: { String } -- identifiers which became keywords, but can still be used as variables 797 | id_keywords : COMMON { "common" } -- allow common as a subname (can happen) 798 | | ALLOCATE { "allocate " } 799 | | id_keywords_2 { $1 } 800 | 801 | id_keywords_2 :: { String } 802 | id_keywords_2 : IN { "in" } 803 | | OUT { "out" } 804 | | LEN { "len" } 805 | 806 | defined_operator :: { BinOp A0 } 807 | defined_operator 808 | -- : defined_binary_op 809 | -- | defined_unary_op 810 | : intrinsic_operator { $1 } 811 | 812 | intrinsic_operator :: { BinOp A0 } 813 | intrinsic_operator 814 | : '**' { Power () } 815 | | '*' { Mul () } 816 | | '+' { Plus () } 817 | | '//' { Concat () } 818 | | rel_op { $1 } 819 | -- | '.NOT.' { Not () } 820 | | '.AND.' { And () } 821 | | '.OR.' { Or () } 822 | 823 | 824 | namelist_stmt :: { Decl A0 } 825 | namelist_stmt 826 | : NAMELIST namelist_list { Namelist () $2 } 827 | 828 | namelist_list :: { [(Expr A0, [Expr A0])] } 829 | namelist_list 830 | : namelist_list ',' '/' constant_p '/' namelist_group_object_list { $1++[($4,$6)] } 831 | | '/' constant_p '/' namelist_group_object_list { [($2,$4)] } 832 | 833 | namelist_group_object_list :: { [Expr A0] } 834 | namelist_group_object_list 835 | : namelist_group_object_list ',' constant_p { $1++[$3] } 836 | | constant_p { [$1] } 837 | 838 | subroutine_stmt :: { (SubName A0, Arg A0, Maybe (BaseType A0)) } 839 | subroutine_stmt 840 | : SUBROUTINE subname args_p newline { ($2,$3,Nothing) } 841 | | SUBROUTINE subname srcloc newline {% (getSrcSpan $3) >>= (\s -> return $ ($2,Arg () (NullArg ()) s,Nothing)) } 842 | | prefix SUBROUTINE subname args_p newline { ($3,$4,Just (fst3 $1)) } 843 | 844 | function_stmt :: { (SubName A0, Arg A0, Maybe (BaseType A0), Maybe (VarName A0)) } 845 | function_stmt 846 | : prefix FUNCTION subname args_p RESULT '(' id2 ')' newline { ($3,$4,Just (fst3 $1),Just (VarName () $7)) } 847 | | prefix FUNCTION subname args_p newline { ($3,$4,Just (fst3 $1),Nothing) } 848 | | FUNCTION subname args_p RESULT '(' id2 ')' newline { ($2,$3,Nothing,Just (VarName () $6)) } 849 | | FUNCTION subname args_p newline { ($2,$3,Nothing,Nothing) } 850 | 851 | subname :: { SubName A0 } 852 | subname 853 | : ID { SubName () $1 } 854 | | id_keywords { SubName () $1 } 855 | 856 | 857 | prefix :: { (BaseType A0, Expr A0, Expr A0) } 858 | prefix 859 | : type_spec { $1 } 860 | | RECURSIVE {% getSrcSpanNull >>= (\s -> return $ (Recursive (), NullExpr () s, NullExpr () s)) } 861 | | PURE {% getSrcSpanNull >>= (\s -> return $ (Pure (), NullExpr () s, NullExpr () s)) } 862 | | ELEMENTAL {% getSrcSpanNull >>= (\s -> return $ (Elemental (), NullExpr () s, NullExpr () s)) } 863 | 864 | args_p :: { Arg A0 } 865 | args_p 866 | : '(' dummy_arg_list srcloc ')' { ($2 (spanExtR ($3, $3) 1)) } 867 | 868 | dummy_arg_list :: { SrcSpan -> Arg A0 } 869 | dummy_arg_list 870 | : dummy_arg_list2 { Arg () $1 } 871 | | {- empty -} { Arg () (NullArg ()) } 872 | 873 | dummy_arg_list2 :: { ArgName A0 } 874 | dummy_arg_list2 875 | : dummy_arg_list2 ',' dummy_arg { ASeq () $1 $3 } 876 | | dummy_arg { $1 } 877 | 878 | dummy_arg :: { ArgName A0 } 879 | dummy_arg 880 | : ID { ArgName () $1 } 881 | | '*' { ArgName () "*" } 882 | 883 | assignment_stmt :: { Fortran A0 } 884 | assignment_stmt 885 | : variable '=' expr { Assg () (spanTrans $1 $3) $1 $3 } 886 | | srcloc ID '(' section_subscript_list ')' '=' expr {% getSrcSpan $1 >>= (\s -> return $ Assg () s (Var () s [(VarName () $2, $4)]) $7) } 887 | 888 | 889 | 890 | -- moved up to assignment_stmt 891 | variable :: { Expr A0 } 892 | variable 893 | : srcloc scalar_variable_name_list {% (getSrcSpan $1) >>= (\s -> return $ Var () s $2) } 894 | 895 | 896 | scalar_variable_name_list :: { [(VarName A0, [Expr A0])] } 897 | scalar_variable_name_list 898 | : scalar_variable_name_list '%' scalar_variable_name { $1++[$3] } 899 | | scalar_variable_name { [$1] } 900 | 901 | 902 | scalar_variable_name :: { (VarName A0, [Expr A0]) } 903 | scalar_variable_name 904 | : ID '(' section_subscript_list ')' { (VarName () $1, $3) } 905 | | ID '(' ')' {% getSrcSpanNull >>= (\s -> return $ (VarName () $1, [NullExpr () s])) } 906 | | ID { (VarName () $1, []) } 907 | | id_keywords_2 {% getSrcSpanNull >>= (\s -> return $ (VarName () $1, [NullExpr () s])) } 908 | 909 | -- | TYPE { (VarName () "type", []) } -- a bit of a hack but 'type' allowed as var name 910 | -- -- but causes REDUCE REDUCE conflicts! 911 | 912 | -- bound comes through int_expr 913 | subscript :: { Expr A0 } 914 | subscript 915 | : int_expr { $1 } 916 | | bound { $1 } 917 | 918 | bound :: { Expr A0 } 919 | bound 920 | : expr ':' expr { Bound () (spanTrans $1 $3) $1 $3 } 921 | | ':' {% getSrcSpanNull >>= (\s -> return $ Bound () s (NullExpr () s) (NullExpr () s)) } 922 | | expr ':' {% getSrcSpanNull >>= (\s' -> return $ Bound () (spanTrans' $1 s') $1 (NullExpr () s')) } 923 | | srcloc ':' expr {% (getSrcSpan $1) >>= (\s@(_, l) -> return $ Bound () s (NullExpr () (l, l)) $3) } 924 | 925 | section_subscript_list :: { [Expr A0] } 926 | section_subscript_list 927 | : section_subscript_list ',' section_subscript { $1++[$3] } 928 | | section_subscript { [$1] } 929 | 930 | section_subscript :: { Expr A0 } 931 | section_subscript 932 | : subscript { $1 } 933 | | srcloc ID '=' expr {% getSrcSpan $1 >>= (\s -> return $ AssgExpr () s $2 $4) } 934 | 935 | 936 | expr :: { Expr A0 } 937 | expr 938 | : level_5_expr { $1 } 939 | 940 | 941 | level_5_expr :: { Expr A0 } 942 | level_5_expr 943 | : equiv_operand { $1 } 944 | 945 | equiv_operand :: { Expr A0 } 946 | equiv_operand 947 | : equiv_operand '.OR.' or_operand { Bin () (spanTrans $1 $3) (Or ()) $1 $3 } 948 | | or_operand { $1 } 949 | 950 | or_operand :: { Expr A0 } 951 | or_operand 952 | : or_operand '.AND.' and_operand { Bin () (spanTrans $1 $3) (And ()) $1 $3 } 953 | | and_operand { $1 } 954 | 955 | 956 | and_operand :: { Expr A0 } 957 | and_operand 958 | : level_4_expr { $1 } 959 | 960 | level_4_expr :: { Expr A0 } 961 | level_4_expr 962 | : level_4_expr rel_op level_3_expr { Bin () (spanTrans $1 $3) $2 $1 $3 } 963 | | level_3_expr { $1 } 964 | 965 | 966 | level_3_expr :: { Expr A0 } 967 | level_3_expr 968 | : level_3_expr '//' level_2_expr { Bin () (spanTrans $1 $3) (Concat ()) $1 $3 } 969 | | level_2_expr { $1 } 970 | 971 | level_2_expr :: { Expr A0 } 972 | level_2_expr 973 | : level_2_expr '+' add_operand { Bin () (spanTrans $1 $3) (Plus ()) $1 $3 } 974 | | level_2_expr '-' add_operand { Bin () (spanTrans $1 $3) (Minus ()) $1 $3 } 975 | | add_operand { $1 } 976 | 977 | add_operand :: { Expr A0 } 978 | add_operand 979 | : add_operand '*' mult_operand { Bin () (spanTrans $1 $3) (Mul ()) $1 $3 } 980 | | add_operand '/' mult_operand { Bin () (spanTrans $1 $3) (Div ()) $1 $3 } 981 | | mult_operand { $1 } 982 | 983 | mult_operand :: { Expr A0 } 984 | mult_operand 985 | : level_1_expr '**' mult_operand { Bin () (spanTrans $1 $3) (Power ()) $1 $3 } 986 | | level_1_expr { $1 } 987 | 988 | level_1_expr :: { Expr A0 } 989 | level_1_expr 990 | : srcloc '-' primary {% getSrcSpan $1 >>= (\s -> return $ Unary () s (UMinus ()) $3) } 991 | | srcloc '.NOT.' primary {% getSrcSpan $1 >>= (\s -> return $ Unary () s (Not ()) $3) } 992 | | primary { $1 } 993 | 994 | primaryP :: { Expr A0 } 995 | primaryP : 996 | srcloc num '*' primary {% getSrcSpan $1 >>= (\s -> return $ Bin () s (Mul ()) (Con () s $2) $4) } 997 | | srcloc '-' primary {% getSrcSpan $1 >>= (\s -> return $ Unary () s (UMinus ()) $3) } 998 | | primary { $1 } 999 | 1000 | 1001 | primary :: { Expr A0 } 1002 | primary 1003 | : constant { $1 } 1004 | | variable { $1 } 1005 | | srcloc type_cast '(' expr ')' {% getSrcSpan $1 >>= (\s -> return $ Var () s [(VarName () $2, [$4])]) } 1006 | 1007 | | array_constructor { $1 } 1008 | | '(' expr ')' { $2 } 1009 | | srcloc SQRT '(' expr ')' {% getSrcSpan $1 >>= (\s -> return $ Sqrt () s $4) } 1010 | 1011 | 1012 | type_cast :: { String } 1013 | type_cast 1014 | : REAL { "REAL" } -- The following supports the type cast notioatn 1015 | | INTEGER { "INTEGER" } 1016 | | LOGICAL { "LOGICAL" } 1017 | | CHARACTER { "CHARACTER" } 1018 | 1019 | 1020 | -- Bit of a conflict here- not entirely sure when this is needed 1021 | -- | srcloc ':' {% getSrcSpan $1 >>= (\s -> return $ Bound () s (NullExpr () s) (NullExpr () s)) } 1022 | 1023 | fields :: { [String] } 1024 | fields 1025 | : fields '.' id2 { $1++[$3] } 1026 | | id2 { [$1] } 1027 | 1028 | array_constructor :: { Expr A0 } 1029 | array_constructor 1030 | : srcloc '(/' expr_list '/)' {% getSrcSpan $1 >>= (\s -> return $ ArrayCon () s $3) } 1031 | 1032 | expr_list :: { [Expr A0] } 1033 | expr_list 1034 | : expr_list ',' expr { $1++[$3] } 1035 | | expr { [$1] } 1036 | 1037 | constant_p :: { Expr A0 } 1038 | constant_p 1039 | : constant_p2 { $1 } 1040 | 1041 | constant_p2 :: { Expr A0 } 1042 | constant_p2 1043 | : srcloc ID {% getSrcSpan $1 >>= (\s -> return $ Var () s [(VarName () $2,[])]) } 1044 | 1045 | constant :: { Expr A0 } 1046 | constant 1047 | : literal_constant { $1 } 1048 | 1049 | literal_constant :: { Expr A0 } 1050 | literal_constant 1051 | : srcloc num {% (getSrcSpan $1) >>= (\s -> return $ Con () s $2) } 1052 | | srcloc ZLIT {% (getSrcSpan $1) >>= (\s -> return $ ConL () s 'z' $2) } 1053 | | srcloc STR {% (getSrcSpan $1) >>= (\s -> return $ ConS () s $2) } 1054 | | logical_literal_constant { $1 } 1055 | 1056 | --lit_mark :: { Char } 1057 | --lit_mark 1058 | --: 'z' { $1 } 1059 | --| 'Z' { $1 } 1060 | --| 'b' { $1 } 1061 | --| 'B' { $1 } 1062 | --| 'o' { $1 } 1063 | --| 'O' { $1 } 1064 | 1065 | logical_literal_constant :: { Expr A0 } 1066 | logical_literal_constant 1067 | : srcloc '.TRUE.' {% (getSrcSpan $1) >>= (\s -> return $ Con () s ".TRUE.") } 1068 | | srcloc '.FALSE.' {% (getSrcSpan $1) >>= (\s -> return $ Con () s ".FALSE.") } 1069 | 1070 | rel_op :: { BinOp A0 } 1071 | : '==' { RelEQ () } 1072 | | '/=' { RelNE () } 1073 | | '<' { RelLT () } 1074 | | '<=' { RelLE () } 1075 | | '>' { RelGT () } 1076 | | '>=' { RelGE () } 1077 | 1078 | int_expr :: { Expr A0 } 1079 | int_expr 1080 | : expr { $1 } 1081 | 1082 | do_variable :: { VarName A0 } 1083 | do_variable 1084 | : ID { VarName () $1 } 1085 | 1086 | do_construct :: { Fortran A0 } 1087 | do_construct 1088 | : block_do_construct { $1 } 1089 | 1090 | block_do_construct :: { Fortran A0 } 1091 | block_do_construct 1092 | : srcloc nonlabel_do_stmt newline do_block {% getSrcSpan $1 >>= (\s -> return $ For () s (fst4 $2) (snd4 $2) (trd4 $2) (frh4 $2) $4) } 1093 | | srcloc DO WHILE '(' logical_expr ')' newline do_block {% getSrcSpan $1 >>= (\s -> return $ DoWhile () s $5 $8) } 1094 | | srcloc DO num ',' loop_control newline do_block_num 1095 | {% do { (fs, n) <- return $ $7; 1096 | s <- getSrcSpan $1; 1097 | if (n == $3) then 1098 | return $ For () s (fst4 $5) (snd4 $5) (trd4 $5) (frh4 $5) fs 1099 | else parseError "DO/END DO labels don't match" 1100 | } } 1101 | | srcloc DO num loop_control newline do_block_num 1102 | {% do { (fs, n) <- return $ $6; 1103 | s <- getSrcSpan $1; 1104 | if (n == $3) then 1105 | return $ For () s (fst4 $4) (snd4 $4) (trd4 $4) (frh4 $4) fs 1106 | else parseError "DO/END DO labels don't match" 1107 | } } 1108 | | srcloc DO num loop_control newline do_block_cont 1109 | {% do { (fs, n) <- return $ $6; 1110 | s <- getSrcSpan $1; 1111 | if (n == $3) then 1112 | return $ For () s (fst4 $4) (snd4 $4) (trd4 $4) (frh4 $4) fs 1113 | else return $ NullStmt () s -- parseError $ "DO/CONTINUE labels don't match" -- NEEDS FIXING! 1114 | } } 1115 | 1116 | nonlabel_do_stmt :: { (VarName A0, Expr A0, Expr A0, Expr A0) } 1117 | nonlabel_do_stmt 1118 | : DO loop_control { $2 } 1119 | | DO {% getSrcSpanNull >>= (\s -> return $ (VarName () "", NullExpr () s, NullExpr () s, NullExpr () s)) } 1120 | 1121 | loop_control :: { (VarName A0, Expr A0, Expr A0, Expr A0) } 1122 | loop_control 1123 | : do_variable '=' int_expr ',' int_expr loop_control2 { ($1,$3,$5,$6) } 1124 | -- | int_expr comma_int_expr_opt comma_opt WHILE '(' scalar_logical_expr ')' 1125 | 1126 | loop_control2 :: { Expr A0 } 1127 | loop_control2 1128 | : ',' int_expr { $2 } 1129 | | {- empty -} {% getSrcSpanNull >>= (\s -> return $ Con () s "1") } 1130 | 1131 | do_block :: { Fortran A0 } 1132 | do_block : line newline do_block { FSeq () (spanTrans $1 $3) $1 $3 } 1133 | | num end_do {% getSrcSpanNull >>= (\s -> return $ NullStmt () s) } 1134 | | end_do {% getSrcSpanNull >>= (\s -> return $ NullStmt () s) } 1135 | 1136 | do_block_num :: { (Fortran A0, String) } 1137 | do_block_num : line newline do_block_num { let (fs, n) = $3 in (FSeq () (spanTrans $1 fs) $1 fs, n) } 1138 | | num end_do {% getSrcSpanNull >>= (\s -> return $ (NullStmt () s, $1)) } 1139 | 1140 | 1141 | do_block_cont :: { (Fortran A0, String) } 1142 | do_block_cont : 1143 | num CONTINUE {% getSrcSpanNull >>= (\s -> return $ (NullStmt () s, $1)) } 1144 | | line newline do_block_cont { let (fs, n) = $3 in (FSeq () (spanTrans $1 fs) $1 fs, n) } 1145 | 1146 | line :: { Fortran A0 } 1147 | line : num executable_constructP {% getSrcSpanNull >>= (\s -> return $ Label () s $1 $2 ) } 1148 | | executable_constructP { $1 } 1149 | 1150 | end_do :: { } 1151 | end_do 1152 | : END DO {} 1153 | | ENDDO {} 1154 | 1155 | block :: { Fortran A0 } 1156 | block 1157 | : executable_construct_list { $1 } 1158 | 1159 | execution_part :: { Fortran A0 } 1160 | execution_part 1161 | : executable_construct_list { $1 } 1162 | 1163 | executable_construct_list :: { Fortran A0 } 1164 | executable_construct_list 1165 | : executable_construct newline executable_construct_list { FSeq () (spanTrans $1 $3) $1 $3 } 1166 | | executable_construct ';' executable_construct_list { FSeq () (spanTrans $1 $3) $1 $3 } 1167 | | executable_construct newline { $1 } 1168 | | executable_construct ';' { $1 } 1169 | 1170 | 1171 | executable_construct :: { Fortran A0 } 1172 | executable_construct 1173 | : num executable_constructP {% (getSrcSpanNull) >>= (\s -> return $ Label () s $1 $2) } 1174 | | executable_constructP { $1 } 1175 | 1176 | executable_constructP :: { Fortran A0 } 1177 | executable_constructP 1178 | : do_construct { $1 } 1179 | | if_construct { $1 } 1180 | | action_stmt { $1 } 1181 | 1182 | 1183 | equivalence_stmt :: { Decl A0 } 1184 | equivalence_stmt 1185 | : srcloc EQUIVALENCE '(' vlist ')' {% getSrcSpan $1 >>= (\s -> return $ Equivalence () s $4) } 1186 | 1187 | action_stmt :: { Fortran A0 } 1188 | action_stmt 1189 | : allocate_stmt { $1 } 1190 | | assignment_stmt { $1 } 1191 | | backspace_stmt { $1 } 1192 | | call_stmt { $1 } 1193 | | close_stmt { $1 } 1194 | | continue_stmt { $1 } 1195 | | cycle_stmt { $1 } 1196 | | srcloc data_stmt {% getSrcSpan $1 >>= (\s -> return $ DataStmt () s $2) } 1197 | | deallocate_stmt { $1 } 1198 | | endfile_stmt { $1 } 1199 | -- | end_function_stmt 1200 | -- | end_program_stmt 1201 | -- | end_subroutine_stmt 1202 | | exit_stmt { $1 } 1203 | | format_stmt { $1 } 1204 | | forall_stmt { $1 } 1205 | | goto_stmt { $1 } 1206 | | if_stmt { $1 } 1207 | | inquire_stmt { $1 } 1208 | | nullify_stmt { $1 } 1209 | | open_stmt { $1 } 1210 | | pointer_assignment_stmt { $1 } 1211 | | print_stmt { $1 } 1212 | | read_stmt { $1 } 1213 | | return_stmt { $1 } 1214 | | pause_stmt { $1 } 1215 | | rewind_stmt { $1 } 1216 | | stop_stmt { $1 } 1217 | | where_stmt { $1 } 1218 | | write_stmt { $1 } 1219 | | srcloc TEXT {% getSrcSpan $1 >>= (\s -> return $ TextStmt () s $2) } 1220 | 1221 | pause_stmt :: { Fortran A0 } 1222 | pause_stmt : srcloc PAUSE STR {% getSrcSpan $1 >>= (\s -> return $ Pause () s $3) } 1223 | 1224 | format_stmt :: { Fortran A0 } 1225 | format_stmt : srcloc FORMAT io_control_spec_list_d {% getSrcSpan $1 >>= (\s -> return $ Format () s $3) } 1226 | 1227 | call_stmt :: { Fortran A0 } 1228 | call_stmt 1229 | : srcloc CALL call_name '(' actual_arg_spec_list ')' {% getSrcSpan $1 >>= (\s -> return $ Call () s $3 (ArgList () $5)) } 1230 | | srcloc CALL call_name '(' ')' {% getSrcSpan $1 >>= (\s -> return $ Call () s $3 (ArgList () (NullExpr () ($1, $1)))) } 1231 | | srcloc CALL call_name {% getSrcSpan $1 >>= (\s -> return $ Call () s $3 (ArgList () (NullExpr () ($1, $1)))) } 1232 | 1233 | call_name :: { Expr A0 } 1234 | call_name 1235 | : srcloc id2 {% (getSrcSpan $1) >>= (\s -> return $ Var () s [(VarName () $2,[])]) } 1236 | 1237 | actual_arg_spec_list :: { Expr A0 } 1238 | actual_arg_spec_list 1239 | : actual_arg_spec_list ',' actual_arg_spec { ESeq () (spanTrans $1 $3) $1 $3 } 1240 | | actual_arg_spec { $1 } 1241 | 1242 | actual_arg_spec :: { Expr A0 } 1243 | actual_arg_spec 1244 | : srcloc ID '=' actual_arg {% getSrcSpan $1 >>= (\s -> return $ AssgExpr () s $2 $4) } 1245 | | actual_arg { $1 } 1246 | 1247 | actual_arg :: { Expr A0 } 1248 | actual_arg 1249 | : expr { $1 } 1250 | -- | variable 1251 | -- | procedre_name 1252 | -- | alt_return_spec 1253 | 1254 | else_if_list :: { [(Expr A0, Fortran A0)] } 1255 | else_if_list 1256 | : else_if_list else_if_then_stmt block { $1++[($2,$3)] } 1257 | | {- empty -} { [] } 1258 | 1259 | else_if_stmt :: { Expr A0 } 1260 | else_if_stmt 1261 | : ELSE if_then_stmt { $2 } 1262 | 1263 | if_then_stmt :: { Expr A0 } 1264 | if_then_stmt 1265 | : IF '(' logical_expr ')' THEN newline { $3 } 1266 | 1267 | 1268 | else_if_then_stmt :: { Expr A0 } 1269 | else_if_then_stmt 1270 | : ELSEIF '(' logical_expr ')' THEN newline { $3 } 1271 | | ELSE IF '(' logical_expr ')' THEN newline { $4 } 1272 | 1273 | 1274 | --if_rest :: { ([(Expr A0,Fortran)],Maybe Fortran) } 1275 | --: ELSE if_then_stmt block if_rest { (($2,$3):(fst $4),snd $4) } 1276 | --| ELSE block END IF { ([],Just $2) } 1277 | --| END IF { ([],Nothing) } 1278 | 1279 | if_construct :: { Fortran A0 } 1280 | if_construct 1281 | : 1282 | -- FORTRAN 77 numerical comparison IFs 1283 | 1284 | srcloc IF '(' logical_expr ')' num ',' num ',' num 1285 | {% getSrcSpan $1 >>= (\s -> return $ If () s (Bin () s (RelLT ()) $4 (Con () s "0")) (Goto () s $6) 1286 | [(Bin () s (RelEQ ()) $4 (Con () s "0"), (Goto () s $8)), 1287 | (Bin () s (RelGT ()) $4 (Con () s "0"), (Goto () s $10))] Nothing) } 1288 | 1289 | -- Other If forms 1290 | 1291 | | srcloc if_then_stmt block end_if_stmt 1292 | {% getSrcSpan $1 >>= (\s -> return $ If () s $2 $3 [] Nothing) } 1293 | 1294 | | srcloc if_then_stmt block else_if_list end_if_stmt 1295 | {% getSrcSpan $1 >>= (\s -> return $ If () s $2 $3 $4 Nothing) } 1296 | 1297 | | srcloc if_then_stmt block else_if_list ELSE newline block end_if_stmt 1298 | {% getSrcSpan $1 >>= (\s -> return $ If () s $2 $3 $4 (Just $7)) } 1299 | 1300 | --| if_then_stmt block ELSE block end_if_stmt {% getSrcSpan $1 (\s -> If s $1 $2 [] (Just $4)) } 1301 | 1302 | --: if_then_stmt block if_rest { (If $1 $2 (fst $3) (snd $3)) } 1303 | --: if_then_stmt block else_if_list END IF { (If $1 $2 $3 Nothing) } 1304 | --| if_then_stmt block else_if_list ELSE block END IF { (If $1 $2 $3 (Just $5)) } 1305 | --| if_then_stmt block END IF { (If $1 $2 [] Nothing) } 1306 | --| if_then_stmt block ELSE block END IF { (If $1 $2 [] (Just $4)) } 1307 | 1308 | -- : if_then_stmt block 1309 | ---- else_if_list 1310 | -- else_opt 1311 | -- END IF { (If $1 $2 $3) } 1312 | 1313 | end_if_stmt :: {} 1314 | end_if_stmt : END IF { } 1315 | | ENDIF { } 1316 | 1317 | 1318 | logical_expr :: { Expr A0 } 1319 | logical_expr 1320 | : expr { $1 } 1321 | 1322 | allocate_stmt :: { Fortran A0 } 1323 | allocate_stmt 1324 | : srcloc ALLOCATE '(' allocation_list ',' STAT '=' variable ')' 1325 | {% getSrcSpan $1 >>= (\s -> return $ Allocate () s $4 $8) } 1326 | 1327 | | srcloc ALLOCATE '(' allocation_list ')' 1328 | {% getSrcSpanNull >>= (\e -> getSrcSpan $1 >>= (\s -> return $ Allocate () s $4 (NullExpr () e))) } 1329 | 1330 | 1331 | allocation_list :: { Expr A0 } 1332 | allocation_list 1333 | : allocation_list ',' allocation { ESeq () (spanTrans $1 $3) $1 $3 } 1334 | | allocation { $1 } 1335 | | {- empty -} {% getSrcSpanNull >>= (return . (NullExpr ())) } 1336 | 1337 | allocate_object_list :: { [Expr A0] } 1338 | allocate_object_list 1339 | : allocate_object_list ',' allocate_object { $1++[$3] } 1340 | | allocate_object { [$1] } 1341 | 1342 | allocate_object :: { Expr A0 } 1343 | allocate_object 1344 | : srcloc scalar_variable_name_list {% getSrcSpan $1 >>= (\s -> return $ Var () s $2) } 1345 | 1346 | allocate_shape_spec_list :: { [Expr A0] } 1347 | allocate_shape_spec_list 1348 | : allocate_shape_spec_list ',' allocate_shape_spec { $1++[$3] } 1349 | | allocate_shape_spec { [$1] } 1350 | 1351 | allocate_shape_spec :: { Expr A0 } 1352 | allocate_shape_spec 1353 | : expr { $1 } 1354 | | bound { $1 } 1355 | 1356 | allocation :: { Expr A0 } 1357 | allocation 1358 | : allocation_var_list2 { $1 } 1359 | 1360 | allocation_var_list2 :: { Expr A0 } 1361 | allocation_var_list2 1362 | : srcloc allocation_var_list {% getSrcSpan $1 >>= (\s -> return $ Var () s $2) } 1363 | 1364 | allocation_var_list :: { [(VarName A0,[Expr A0])] } 1365 | allocation_var_list 1366 | : allocation_var_list '%' allocation_var { $1++[$3] } 1367 | | allocation_var { [$1] } 1368 | 1369 | allocation_var :: { (VarName A0, [Expr A0]) } 1370 | allocation_var 1371 | : ID '(' allocate_shape_spec_list ')' { (VarName () $1, $3) } 1372 | | ID { (VarName () $1, []) } 1373 | 1374 | backspace_stmt :: { Fortran A0 } 1375 | backspace_stmt 1376 | : srcloc BACKSPACE expr {% getSrcSpan $1 >>= (\s -> return $ Backspace () s [NoSpec () $3]) } 1377 | | srcloc BACKSPACE '(' position_spec_list ')' {% getSrcSpan $1 >>= (\s -> return $ Backspace () s $4) } 1378 | 1379 | position_spec_list :: { [Spec A0] } 1380 | position_spec_list 1381 | : position_spec_list ',' position_spec { $1++[$3] } 1382 | | position_spec { [$1] } 1383 | 1384 | position_spec :: { Spec A0 } 1385 | position_spec 1386 | : expr { NoSpec () $1 } 1387 | | srcloc UNIT '=' expr { Unit () $4 } -- units-of-measure 1388 | | srcloc ID '=' expr {% case (map (toLower) $2) of 1389 | -- "unit" -> return (Unit () $4) 1390 | "iostat" -> return (IOStat () $4) 1391 | s -> parseError ("incorrect name in spec list: " ++ s) } 1392 | 1393 | close_stmt :: { Fortran A0 } 1394 | close_stmt 1395 | : srcloc CLOSE '(' close_spec_list ')' {% getSrcSpan $1 >>= (\s -> return $ Close () s $4) } 1396 | 1397 | close_spec_list :: { [Spec A0] } 1398 | close_spec_list 1399 | : close_spec_list ',' close_spec { $1++[$3] } 1400 | | close_spec { [$1] } 1401 | 1402 | close_spec :: { Spec A0 } 1403 | close_spec 1404 | : expr { NoSpec () $1 } 1405 | | UNIT '=' expr { Unit () $3 } -- units-of-measure 1406 | | ID '=' expr 1407 | {% case (map (toLower) $1) of 1408 | "iostat" -> return (IOStat () $3) 1409 | "status" -> return (Status () $3) 1410 | s -> parseError ("incorrect name in spec list: " ++ s) } 1411 | 1412 | --external_file_unit :: { Expr A0 } 1413 | --external_file_unit 1414 | -- : expr { $1 } 1415 | 1416 | continue_stmt :: { Fortran A0 } 1417 | continue_stmt 1418 | : srcloc CONTINUE {% getSrcSpan $1 >>= (return . (Continue ())) } 1419 | 1420 | cycle_stmt :: { Fortran A0 } 1421 | cycle_stmt 1422 | : srcloc CYCLE id2 {% getSrcSpan $1 >>= (\s -> return $ Cycle () s $3) } 1423 | | srcloc CYCLE {% getSrcSpan $1 >>= (\s -> return $ Cycle () s "") } 1424 | 1425 | deallocate_stmt :: { Fortran A0 } 1426 | deallocate_stmt 1427 | : srcloc DEALLOCATE '(' allocate_object_list ',' STAT '=' variable ')' 1428 | {% getSrcSpan $1 >>= (\s -> return $ Deallocate () s $4 $8) } 1429 | 1430 | | srcloc DEALLOCATE '(' allocate_object_list ')' 1431 | {% getSrcSpan $1 >>= (\s -> return $ Deallocate () s $4 (NullExpr () s)) } 1432 | 1433 | endfile_stmt :: { Fortran A0 } 1434 | endfile_stmt 1435 | : srcloc ENDFILE expr {% getSrcSpan $1 >>= (\s -> return $ Endfile () s [NoSpec () $3]) } 1436 | | srcloc ENDFILE '(' position_spec_list ')' {% getSrcSpan $1 >>= (\s -> return $ Endfile () s $4) } 1437 | 1438 | exit_stmt :: { Fortran A0 } 1439 | exit_stmt 1440 | : srcloc EXIT id2 {% getSrcSpan $1 >>= (\s -> return $ Exit () s $3) } 1441 | | srcloc EXIT {% getSrcSpan $1 >>= (\s -> return $ Exit () s "") } 1442 | 1443 | forall_stmt :: { Fortran A0 } 1444 | forall_stmt 1445 | : srcloc FORALL forall_header forall_assignment_stmt 1446 | {% getSrcSpan $1 >>= (\s -> return $ Forall () s $3 $4) } 1447 | 1448 | | srcloc FORALL forall_header newline forall_assignment_stmt_list forall_stmt_end 1449 | {% getSrcSpan $1 >>= (\s -> return $ Forall () s $3 $5) } 1450 | 1451 | forall_stmt_end :: {} 1452 | forall_stmt_end 1453 | : END FORALL {} 1454 | | {- empty -} {} 1455 | 1456 | forall_header :: { ([(String,Expr A0,Expr A0,Expr A0)],Expr A0) } 1457 | forall_header 1458 | : '(' forall_triplet_spec_list ',' expr ')' { ($2,$4) } 1459 | | '(' forall_triplet_spec_list ')' {% getSrcSpanNull >>= (\s -> return ($2, NullExpr () s)) } 1460 | 1461 | forall_triplet_spec_list :: { [(String,Expr A0,Expr A0,Expr A0)] } 1462 | forall_triplet_spec_list 1463 | : forall_triplet_spec_list ',' forall_triplet_spec { $1++[$3]} 1464 | | forall_triplet_spec { [$1] } 1465 | 1466 | forall_triplet_spec :: { (String,Expr A0,Expr A0,Expr A0) } 1467 | forall_triplet_spec 1468 | : id2 '=' int_expr ':' int_expr ';' int_expr { ($1,$3,$5,$7) } 1469 | | id2 '=' int_expr ':' int_expr {% getSrcSpanNull >>= (\s -> return ($1,$3,$5,NullExpr () s)) } 1470 | 1471 | forall_assignment_stmt :: { Fortran A0 } 1472 | forall_assignment_stmt 1473 | : assignment_stmt { $1 } 1474 | | pointer_assignment_stmt { $1 } 1475 | 1476 | 1477 | forall_assignment_stmt_list :: { Fortran A0 } 1478 | forall_assignment_stmt_list 1479 | : forall_assignment_stmt newline forall_assignment_stmt_list { FSeq () (spanTrans $1 $3) $1 $3 } 1480 | | forall_assignment_stmt newline { $1 } 1481 | 1482 | 1483 | goto_stmt :: { Fortran A0 } 1484 | goto_stmt 1485 | : srcloc GOTO num {% getSrcSpan $1 >>= (\s -> return $ Goto () s $3) } 1486 | 1487 | if_stmt :: { Fortran A0 } 1488 | if_stmt 1489 | : srcloc IF '(' logical_expr ')' action_stmt {% getSrcSpan $1 >>= (\s -> return $ If () s $4 $6 [] Nothing) } 1490 | 1491 | inquire_stmt :: { Fortran A0 } 1492 | inquire_stmt 1493 | : srcloc INQUIRE '(' inquire_spec_list ')' 1494 | {% getSrcSpan $1 >>= (\s -> return $ Inquire () s $4 []) } 1495 | | srcloc INQUIRE '(' IOLENGTH '=' variable ')' output_item_list 1496 | 1497 | {% getSrcSpan $1 >>= (\s -> return $ Inquire () s [IOLength () $6] $8) } 1498 | 1499 | inquire_spec_list :: { [Spec A0] } 1500 | inquire_spec_list 1501 | : inquire_spec_list ',' inquire_spec { $1++[$3] } 1502 | | inquire_spec { [$1] } 1503 | 1504 | inquire_spec :: { Spec A0 } 1505 | inquire_spec 1506 | : expr { NoSpec () $1 } 1507 | | UNIT '=' variable { Unit () $3 } -- units-of-measure 1508 | | READ '=' variable { Read () $3 } 1509 | | WRITE '=' variable { WriteSp () $3 } 1510 | | ID '=' expr {% case (map (toLower) $1) of 1511 | "file" -> return (File () $3) 1512 | "iostat" -> return (IOStat () $3) 1513 | "exist" -> return (Exist () $3) 1514 | "opened" -> return (Opened () $3) 1515 | "number" -> return (Number () $3) 1516 | "named" -> return (Named () $3) 1517 | "name" -> return (Name () $3) 1518 | "access" -> return (Access () $3) 1519 | "sequential" -> return (Sequential () $3) 1520 | "direct" -> return (Direct () $3) 1521 | "form" -> return (Form () $3) 1522 | "formatted" -> return (Formatted () $3) 1523 | "unformatted" -> return (Unformatted () $3) 1524 | "recl" -> return (Recl () $3) 1525 | "nextrec" -> return (NextRec () $3) 1526 | "blank" -> return (Blank () $3) 1527 | "position" -> return (Position () $3) 1528 | "action" -> return (Action () $3) 1529 | "readwrite" -> return (ReadWrite () $3) 1530 | "delim" -> return (Delim () $3) 1531 | "pad" -> return (Pad () $3) 1532 | s -> parseError ("incorrect name in spec list: " ++ s) } 1533 | --io_implied_do 1534 | --io_implied_do 1535 | -- : '(' io_implied_do_object_list ',' io_implied_do_control ')' 1536 | --io_implied_do_object 1537 | --io_implied_do_object 1538 | -- : input_item 1539 | -- | output_item 1540 | --io_implied_do_control 1541 | --io_implied_do_control 1542 | -- : do_variable '=' scalar_int_expr ',' scalar_int_expr ',' scalar_int_expr 1543 | -- | do_variable '=' scalar_int_expr ',' scalar_int_expr 1544 | --file_name_expr 1545 | --file_name_expr 1546 | -- : scalar_char_expr 1547 | 1548 | 1549 | 1550 | nullify_stmt :: { Fortran A0 } 1551 | nullify_stmt 1552 | : srcloc NULLIFY '(' pointer_object_list ')' {% getSrcSpan $1 >>= (\s -> return $ Nullify () s $4) } 1553 | 1554 | pointer_object_list :: { [Expr A0] } 1555 | pointer_object_list 1556 | : pointer_object_list ',' pointer_object { $1++[$3] } 1557 | | pointer_object { [$1] } 1558 | 1559 | pointer_object :: { Expr A0 } 1560 | pointer_object 1561 | : structure_component { $1 } 1562 | 1563 | structure_component :: { Expr A0 } 1564 | structure_component 1565 | : variable { $1 } 1566 | 1567 | open_stmt :: { Fortran A0 } 1568 | open_stmt 1569 | : srcloc OPEN '(' connect_spec_list ')' {% getSrcSpan $1 >>= (\s -> return $ Open () s $4) } 1570 | 1571 | connect_spec_list :: { [Spec A0] } 1572 | connect_spec_list 1573 | : connect_spec_list ',' connect_spec { $1++[$3] } 1574 | | connect_spec { [$1] } 1575 | 1576 | connect_spec :: { Spec A0 } 1577 | connect_spec 1578 | : expr { NoSpec () $1 } 1579 | | UNIT '=' expr { Unit () $3 } 1580 | | ID '=' expr {% case (map (toLower) $1) of 1581 | "iostat" -> return (IOStat () $3) 1582 | "file" -> return (File () $3) 1583 | "status" -> return (Status () $3) 1584 | "access" -> return (Access () $3) 1585 | "form" -> return (Form () $3) 1586 | "recl" -> return (Recl () $3) 1587 | "blank" -> return (Blank () $3) 1588 | "position" -> return (Position () $3) 1589 | "action" -> return (Action () $3) 1590 | "delim" -> return (Delim () $3) 1591 | "pad" -> return (Pad () $3) 1592 | s -> parseError ("incorrect name in spec list: " ++ s) } 1593 | 1594 | file_name_expr :: { Expr A0 } 1595 | file_name_expr 1596 | : scalar_char_expr { $1 } 1597 | 1598 | scalar_char_expr :: { Expr A0 } 1599 | scalar_char_expr 1600 | : expr { $1 } 1601 | 1602 | scalar_int_expr :: { Expr A0 } 1603 | scalar_int_expr 1604 | : expr { $1 } 1605 | 1606 | pointer_assignment_stmt :: { Fortran A0 } 1607 | pointer_assignment_stmt 1608 | : srcloc pointer_object '=>' target {% getSrcSpan $1 >>= (\s -> return $ PointerAssg () s $2 $4) } 1609 | 1610 | target :: { Expr A0 } 1611 | target 1612 | : expr { $1 } 1613 | 1614 | 1615 | 1616 | print_stmt :: { Fortran A0 } 1617 | print_stmt 1618 | : srcloc PRINT format ',' output_item_list {% getSrcSpan $1 >>= (\s -> return $ Print () s $3 $5) } 1619 | | srcloc PRINT format {% getSrcSpan $1 >>= (\s -> return $ Print () s $3 []) } 1620 | 1621 | -- also replaces io_unit 1622 | format :: { Expr A0 } 1623 | format 1624 | : expr { $1 } 1625 | -- | literal_constant { (Con $1) } -- label 1626 | | '*' {% getSrcSpanNull >>= (\s -> return $ Var () s [(VarName () "*",[])]) } 1627 | 1628 | output_item_list :: { [Expr A0] } 1629 | output_item_list 1630 | : output_item_list ',' output_item { $1++[$3] } 1631 | | output_item { [$1] } 1632 | 1633 | output_item :: { Expr A0 } 1634 | output_item 1635 | : expr { $1 } 1636 | | '(' actual_arg_spec_list ')' { $2 } 1637 | -- | io_implied_do { $1 } 1638 | 1639 | 1640 | read_stmt :: { Fortran A0 } 1641 | read_stmt 1642 | : srcloc READ '(' io_control_spec_list ')' input_item_list {% getSrcSpan $1 >>= (\s -> return $ ReadS () s $4 $6) } 1643 | | srcloc READ io_control_spec ',' input_item_list {% getSrcSpan $1 >>= (\s -> return $ ReadS () s $3 $5) } 1644 | | srcloc READ '(' io_control_spec_list ')' {% getSrcSpan $1 >>= (\s -> return $ ReadS () s $4 []) } 1645 | 1646 | 1647 | io_control_spec_list_d :: { [Spec A0] } 1648 | io_control_spec_list_d : 1649 | '(/' ',' io_control_spec_list_d2 { (Delimiter ()):$3 } 1650 | | '(' io_control_spec_list_d2 { $2 } 1651 | 1652 | {- 1653 | 1654 | | '(/' ',' io_control_spec_list '/)' { ((Delimiter ()):$3) ++ [Delimiter ()] } 1655 | | '(' io_control_spec_list '/)' { $2 ++ [Delimiter ()] } 1656 | '(/' ',' io_control_spec_list ',' '/)' { ((Delimiter ()):$3) ++ [Delimiter ()] } 1657 | | '(' io_control_spec_list ',' '/)' { $2 ++ [Delimiter ()] } 1658 | -} 1659 | 1660 | 1661 | io_control_spec_list_d2 :: { [Spec A0] } 1662 | io_control_spec_list_d2 : 1663 | io_control_spec ',' io_control_spec_list_d2 { $1 ++ $3 } 1664 | | '/)' { [Delimiter ()] } 1665 | | io_control_spec ')' { $1 } 1666 | | io_control_spec '/)' { $1 ++ [Delimiter ()] } 1667 | 1668 | 1669 | io_control_spec_list :: { [Spec A0] } 1670 | io_control_spec_list : 1671 | io_control_spec ',' io_control_spec_list { $1 ++ $3 } 1672 | | io_control_spec { $1 } 1673 | 1674 | -- (unit, fmt = format), (rec, advance = expr), (nml, iostat, id = var), (err, end, eor = label) 1675 | 1676 | io_control_spec :: { [Spec A0] } 1677 | io_control_spec 1678 | : --format { [NoSpec () $1] } 1679 | '/' { [Delimiter ()] } 1680 | | '*' {% getSrcSpanNull >>= (\s -> return $ [NoSpec () (Var () s [(VarName () "*", [])])]) } 1681 | | STR { [StringLit () $1] } 1682 | | STR '/' { [StringLit () $1, Delimiter ()] } 1683 | | END '=' label { [End () $3] } 1684 | | io_control_spec_id { [$1] } 1685 | | num {% getSrcSpanNull >>= (\s -> return $ [Number () (Con () s $1)]) } 1686 | | floating_spec { [$1] } 1687 | 1688 | 1689 | floating_spec :: { Spec A0 } 1690 | floating_spec : DATA_DESC {% getSrcSpanNull >>= (\s -> return $ Floating () (NullExpr () s) (Con () s $1) ) } 1691 | | num DATA_DESC {% getSrcSpanNull >>= (\s -> return $ Floating () (Con () s $1) (Con () s $2)) } 1692 | 1693 | io_control_spec_id :: { Spec A0 } 1694 | : variable { NoSpec () $1 } 1695 | --| UNIT '=' format { Unit () $3 } 1696 | --| ID '=' format {% case (map (toLower) $1) of 1697 | -- "fmt" -> return (FMT () $3) 1698 | -- "rec" -> return (Rec () $3) 1699 | -- "advance" -> return (Advance () $3) 1700 | -- "nml" -> return (NML () $3) 1701 | -- "iostat" -> return (IOStat () $3) 1702 | -- "size" -> return (Size () $3) 1703 | -- "eor" -> return (Eor () $3) 1704 | -- s -> parseError ("incorrect name in spec list: " ++ s) } 1705 | 1706 | -- | namelist_group_name { NoSpec $1 } 1707 | 1708 | input_item_list :: { [Expr A0] } 1709 | input_item_list 1710 | : input_item_list ',' input_item { $1++[$3] } 1711 | | input_item { [$1] } 1712 | 1713 | input_item :: { Expr A0 } 1714 | input_item 1715 | : variable { $1 } 1716 | 1717 | 1718 | -- | io_implied_do 1719 | --io_unit :: { Expr A0 } 1720 | --io_unit 1721 | -- : expr { $1 } 1722 | -- | '*' { (Var [(VarName () "*",[])]) } 1723 | -- | internal_file_unit { $1 } 1724 | 1725 | label :: { Expr A0 } 1726 | label 1727 | : srcloc LABEL {% (getSrcSpan $1) >>= (\s -> return $ Con () s $2) } 1728 | 1729 | num :: { String } 1730 | num 1731 | : NUM { $1 } 1732 | | '1' { "1" } 1733 | 1734 | --internal_file_unit :: { Expr A0 } 1735 | --internal_file_unit 1736 | -- : default_char_variable { $1 } 1737 | 1738 | --default_char_variable :: { Expr A0 } 1739 | --default_char_variable 1740 | -- : variable { $1 } 1741 | 1742 | namelist_group_name :: { Expr A0 } 1743 | namelist_group_name 1744 | : variable { $1 } 1745 | 1746 | 1747 | return_stmt :: { Fortran A0 } 1748 | return_stmt 1749 | : srcloc RETURN {% getSrcSpan $1 >>= (\s -> return $ Return () s (NullExpr () s)) } 1750 | | srcloc RETURN int_expr {% getSrcSpan $1 >>= (\s -> return $ Return () s $3) } 1751 | 1752 | scalar_default_int_variable :: { Expr A0 } 1753 | scalar_default_int_variable 1754 | : variable { $1 } 1755 | 1756 | scalar_default_char_expr :: { Expr A0 } 1757 | scalar_default_char_expr 1758 | : expr { $1 } 1759 | 1760 | rewind_stmt :: { Fortran A0 } 1761 | rewind_stmt 1762 | : srcloc REWIND expr {% getSrcSpan $1 >>= (\s -> return $ Rewind () s [NoSpec () $3]) } 1763 | | srcloc REWIND '(' position_spec_list ')' {% getSrcSpan $1 >>= (\s -> return $ Rewind () s $4) } 1764 | 1765 | 1766 | 1767 | stop_stmt :: { Fortran A0 } 1768 | stop_stmt 1769 | : srcloc STOP stop_code {% getSrcSpan $1 >>= (\s -> return $ Stop () s $3) } 1770 | | srcloc STOP {% getSrcSpan $1 >>= (\s -> return $ Stop () s (NullExpr () s)) } 1771 | 1772 | stop_code :: { Expr A0 } 1773 | stop_code 1774 | : constant { $1 } 1775 | 1776 | 1777 | 1778 | where_stmt :: { Fortran A0 } 1779 | where_stmt 1780 | : srcloc WHERE '(' mask_expr ')' where_assignment_stmt {% getSrcSpan $1 >>= (\s -> return $ Where () s $4 $6 Nothing) } 1781 | | srcloc WHERE '(' mask_expr ')' newline where_assignment_stmt {% getSrcSpan $1 >>= (\s -> return $ Where () s $4 $7 Nothing) } 1782 | | srcloc WHERE '(' mask_expr ')' newline where_assignment_stmt newline ELSEWHERE newline where_assignment_stmt 1783 | newline END WHERE {% getSrcSpan $1 >>= (\s -> return $ Where () s $4 $7 (Just $11)) } 1784 | 1785 | where_assignment_stmt :: { Fortran A0 } 1786 | where_assignment_stmt 1787 | : assignment_stmt { $1 } 1788 | mask_expr :: { Expr A0 } 1789 | mask_expr 1790 | : logical_expr { $1 } 1791 | 1792 | 1793 | 1794 | write_stmt :: { Fortran A0 } 1795 | write_stmt 1796 | : WRITE '(' io_control_spec_list ')' output_item_list {% getSrcSpanNull >>= (\s -> return $ Write () s $3 $5) } 1797 | | WRITE '(' io_control_spec_list ')' {% getSrcSpanNull >>= (\s -> return $ Write () s $3 []) } 1798 | 1799 | srcloc :: { SrcLoc } : {% getSrcLoc' } 1800 | 1801 | { 1802 | 1803 | getSrcLoc' = do (LH.SrcLoc f l c) <- getSrcLoc 1804 | return (SrcLoc f l (c - 1)) 1805 | 1806 | -- Initial annotations from parser 1807 | 1808 | -- Type of annotations 1809 | 1810 | type A0 = () 1811 | 1812 | getSrcSpan :: SrcLoc -> P (SrcLoc, SrcLoc) 1813 | getSrcSpan l = do l' <- getSrcLoc' 1814 | return $ (l, l') 1815 | 1816 | -- 0-length span at current position 1817 | 1818 | getSrcSpanNull :: P (SrcLoc, SrcLoc) 1819 | getSrcSpanNull = do l <- getSrcLoc' 1820 | return $ (l, l) 1821 | 1822 | spanTrans x y = let (l, _) = srcSpan x 1823 | (_, l') = srcSpan y 1824 | in (l, l') 1825 | 1826 | spanTrans' x (_, l') = let (l, _) = srcSpan x 1827 | in (l, l') 1828 | 1829 | spanExtendR t x = let (l, l') = srcSpan t 1830 | in (l, SrcLoc (srcFilename l') (srcLine l') (srcColumn l' + x)) 1831 | 1832 | spanExtR (l, l') x = (l, SrcLoc (srcFilename l') (srcLine l') (srcColumn l' + x)) 1833 | 1834 | spanExtendL t x = let (l, l') = srcSpan t 1835 | in (SrcLoc (srcFilename l) (srcLine l) (srcColumn l - x), l') 1836 | 1837 | happyError :: P a 1838 | happyError = parseError "syntax error (from parser)" 1839 | 1840 | parseError :: String -> P a 1841 | parseError m = do srcloc <- getSrcLoc' 1842 | fail (srcFilename srcloc ++ ": line " ++ show (srcLine srcloc) ++ " column " ++ show (srcColumn srcloc) ++ ": " ++ m ++ "\n") 1843 | 1844 | tokenFollows s = case alexScan ('\0',[],s) 0 of 1845 | AlexEOF -> "end of file" 1846 | AlexError _ -> "" 1847 | AlexSkip (_,b,t) len -> tokenFollows t 1848 | AlexToken (_,b,t) len _ -> take len s 1849 | 1850 | parse :: String -> Program A0 1851 | parse p = case (runParser parser (pre_process p)) of 1852 | (ParseOk p) -> p 1853 | (ParseFailed l e) -> error e 1854 | 1855 | --parse :: String -> [Program] 1856 | --parse = clean . parser . fixdecls . scan 1857 | 1858 | parseF :: String -> IO () 1859 | parseF f = do s <- readFile f 1860 | print (parse s) 1861 | 1862 | --scanF :: String -> IO () 1863 | --scanF f = do s <- readFile f 1864 | -- print (scan s) 1865 | 1866 | fst3 (a,b,c) = a 1867 | snd3 (a,b,c) = b 1868 | trd3 (a,b,c) = c 1869 | 1870 | fst4 (a,b,c,d) = a 1871 | snd4 (a,b,c,d) = b 1872 | trd4 (a,b,c,d) = c 1873 | frh4 (a,b,c,d) = d 1874 | 1875 | cmpNames :: SubName A0 -> String -> String -> P (SubName A0) 1876 | cmpNames x "" z = return x 1877 | cmpNames (SubName a x) y z | x==y = return (SubName a x) 1878 | | otherwise = parseError (z ++ " name \""++x++"\" does not match \""++y++"\" in end " ++ z ++ " statement\n") 1879 | cmpNames s y z = parseError (z ++" names do not match\n") 1880 | 1881 | expr2array_spec (Bound _ _ e e') = (e, e') -- possibly a bit dodgy- uses undefined 1882 | expr2array_spec e = (NullExpr () (srcSpan e) , e) 1883 | 1884 | } 1885 | -------------------------------------------------------------------------------- /src/Language/Fortran/PreProcess.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | 3 | The following provides a string → string preprocessor for Fortran 4 | programs that deals with label-delimited @do@-@continue@ blocks of 5 | FORTRAN 77 era. With a traditional LR(1) parser, these are not easily 6 | (or not at all) parsable. Consider the valid FORTRAN 77 code: 7 | 8 | > do j = 1,5 9 | > do 17 i=1,10 10 | > print *,i 11 | > 17 continue 12 | > end do 13 | 14 | Here the \'continue\' acts as an \'end do\' (not as a usual 15 | \'continue\' statement) because it is labelled with the same label 16 | \'17\' as the \'do\' statement which starts the block. Parsing this 17 | requires arbitrary look-ahead (e.g., LR(infinity)) which is provided 18 | by the following parsec parser, but not by the \'happy\' parser 19 | generator. 20 | 21 | This pre processor is currently quite heavy handed. It replaces 22 | \'continue\' in the above program with \'end do\'. E.g., the above 23 | program is transformed to: 24 | 25 | > do j = 1,5 26 | > do 17 i=1,10 27 | > print *,i 28 | > 17 end do 29 | > end do 30 | -} 31 | module Language.Fortran.PreProcess ( 32 | pre_process 33 | , parseExpr 34 | ) where 35 | 36 | import Text.ParserCombinators.Parsec hiding (spaces) 37 | import System.Environment 38 | 39 | 40 | num = many1 digit 41 | small = lower <|> char '_' 42 | idchar = small <|> upper <|> digit 43 | ident = do{ c <- small <|> upper ; cs <- many idchar; return (c:cs) } 44 | spaces = many space 45 | 46 | manyTillEnd p end = 47 | scan where scan = (try end) <|> do { x <- p; xs <- scan; return (x:xs) } 48 | 49 | pre_parser labels = manyTillEnd anyChar 50 | (try $ if null labels then try (end_or_start_do labels) <|> (eof >> return "") 51 | else end_or_start_do labels) 52 | 53 | end_or_start_do labels = (try $ doBlock labels) <|> (end_do labels) 54 | 55 | doBlock labels = 56 | do doStr <- string "do" <|> string "DO" 57 | updateState (+1) 58 | sp <- spaces 59 | label <- (try numberedBlock) <|> (do { loop <- loop_control; return (Nothing, loop) }) 60 | p <- pre_parser $ (fst label) : labels 61 | return $ doStr ++ sp ++ snd label ++ p 62 | 63 | 64 | end_do labels = do label' <- optionMaybe (do {space; n <- num; space; return n}) 65 | sp <- spaces 66 | lookAhead (end_do_marker <|> continue) 67 | ender <- 68 | case (labels, label') of 69 | ([], _) -> do { ender <- end_do_marker; return $ sp ++ ender } 70 | (Nothing:_, _) -> do { ender <- end_do_marker; return $ sp ++ ender } 71 | ((Just n):_, Nothing) -> do { ender <- end_do_marker; return $ sp ++ ender } 72 | ((Just n):_, Just m) -> if (n==m) then do ender <- end_do_marker <|> continue 73 | return $ " " ++ m ++ " " ++ sp ++ ender 74 | 75 | else -- Labels don't match! 76 | -- If the label doesn't appear anywhere in the label stack, 77 | -- then this is allowed (e.g. extra 'continue' points) 78 | if Just m `notElem` labels then 79 | do ender <- end_do_marker <|> continue_non_replace 80 | return $ " " ++ m ++ " " ++ sp ++ ender 81 | else 82 | -- otherwise, we consider the do loops to be not properly bracketted 83 | error $ "Ill formed do blocks, labels do not match: " ++ n ++ " and " ++ m ++ 84 | " - with label stack " ++ (show labels) 85 | level <- getState 86 | updateState (\x -> x-1) -- "Level " ++ show level) `trace` ( 87 | p <- pre_parser (if labels == [] then [] else tail labels) 88 | return $ ender ++ p 89 | 90 | continue_non_replace = string "continue" <|> string "CONTINUE" 91 | 92 | continue = do string "continue" <|> string "CONTINUE" 93 | return "end do " -- replaces continue with 'end do', this is the goal! 94 | 95 | end_do_marker = do endStr <- string "end" <|> string "END" 96 | sp <- spaces 97 | doStr <- string "do" <|> string "DO" 98 | return $ endStr ++ sp ++ doStr 99 | 100 | numberedBlock = do label <- num 101 | space 102 | sp1 <- spaces 103 | comma <- optionMaybe (string ",") 104 | sp2 <- spaces 105 | loop <- loop_control 106 | return $ (Just label, label ++ " " ++ sp1 ++ (maybe "" id comma) ++ sp2 ++ loop) 107 | 108 | newline' = 109 | (try $ do { c <- char '\r'; 110 | n <- newline; 111 | return [c,n] }) 112 | <|> do { n <- newline; 113 | return [n] } 114 | 115 | loop_control = do var <- ident 116 | sp1 <- spaces 117 | char '=' 118 | sp2 <- spaces 119 | lower <- num <|> ident 120 | sp3 <- spaces 121 | char ',' 122 | sp4 <- spaces 123 | upper <- num <|> ident 124 | rest <- manyTillEnd anyChar (try newline') 125 | return $ var ++ sp1 ++ "=" ++ sp2 ++ lower ++ sp3 ++ "," ++ sp4 ++ upper ++ rest 126 | 127 | parseExpr :: String -> String -> String 128 | parseExpr file input = 129 | case (runParser p (0::Int) "" input) of 130 | Left err -> fail $ show err 131 | Right x -> x 132 | where 133 | p = do pos <- getPosition 134 | setPosition $ (flip setSourceName) file $ 135 | (flip setSourceLine) 1 $ 136 | (flip setSourceColumn) 1 $ pos 137 | pre_parser [] 138 | 139 | pre_process :: String -> String 140 | pre_process = parseExpr "" 141 | 142 | go filename = do args <- getArgs 143 | srcfile <- readFile filename 144 | return $ parseExpr filename srcfile 145 | -------------------------------------------------------------------------------- /src/Language/Fortran/Pretty.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- Pretty.hs - 3 | -- Based on code by Martin Erwig from Parameterized Fortran 4 | -- 5 | 6 | {-# LANGUAGE ExistentialQuantification #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE DeriveDataTypeable #-} 12 | {-# LANGUAGE QuasiQuotes #-} 13 | {-# LANGUAGE DeriveFunctor #-} 14 | {-# LANGUAGE ImplicitParams #-} 15 | {-# LANGUAGE OverlappingInstances #-} 16 | 17 | module Language.Fortran.Pretty where 18 | 19 | import Language.Fortran 20 | import Debug.Trace 21 | import Data.List 22 | 23 | data Alt1 = Alt1 24 | data Alt2 = Alt2 25 | data Alt3 = Alt3 26 | 27 | class Alts a 28 | instance Alts Alt1 29 | instance Alts Alt2 30 | instance Alts Alt3 31 | 32 | --instance (OutputF (ProgUnit p) Alt1) => Show (ProgUnit p) where 33 | -- show p = let ?variant = Alt1 in outputF p 34 | 35 | class OutputF t v where 36 | outputF :: (?variant :: v) => t -> String 37 | 38 | class OutputG t v where 39 | outputG :: (?variant :: v) => t -> String 40 | 41 | -- Default alt1 instance 42 | instance (OutputF t Alt1) => OutputG t Alt1 where 43 | outputG = outputF 44 | 45 | instance Alts v => OutputG Char v where 46 | outputG = show 47 | 48 | instance Alts v => OutputG String v where 49 | outputG = id 50 | 51 | instance (Alts v, OutputG a v, OutputG b v) => OutputG (a, b) v where 52 | outputG (a, b) = "(" ++ outputG a ++ ", " ++ outputG b ++ ")" 53 | 54 | instance (Alts v, OutputG a v) => OutputG [a] v where 55 | outputG xs = "[" ++ go xs ++ "]" where go [] = "" 56 | go [x] = outputG x 57 | go (x:xs) = outputG x ++ ", " ++ (go xs) 58 | 59 | instance (Alts v, OutputG a v) => OutputF [a] v where 60 | outputF xs = "[" ++ go xs ++ "]" where go [] = "" 61 | go [x] = outputG x 62 | go (x:xs) = outputG x ++ ", " ++ (go xs) 63 | 64 | class OutputIndF t v where 65 | outputIndF :: (?variant :: v) => Int -> t -> String 66 | 67 | class OutputIndG t v where 68 | outputIndG :: (?variant :: v) => Int -> t -> String 69 | 70 | instance (OutputIndF t Alt1) => OutputIndG t Alt1 where 71 | outputIndG = outputIndF 72 | 73 | 74 | -- Fortran pretty printer 75 | 76 | --showAllocate ((e,b):[]) = outputG e++"("++showRanges b++")" --new 77 | --showAllocate ((e,b):as) = outputG e++"("++showRanges b++")"++", "++showAllocate as --new 78 | 79 | 80 | -- showElseIf :: Int -> (Expr,Fortran) -> String 81 | 82 | showElseIf i (e,f) = (ind i)++"else if ("++outputG e++") then\n"++(ind (i+1))++outputG f++"\n" 83 | 84 | showForall [] = "error" 85 | showForall ((s,e,e',NullExpr _ _):[]) = s++"="++outputG e++":"++outputG e' 86 | showForall ((s,e,e',e''):[]) = s++"="++outputG e++":"++outputG e'++"; "++outputG e'' 87 | showForall ((s,e,e',NullExpr _ _):is) = s++"="++outputG e++":"++outputG e'++", "++showForall is 88 | showForall ((s,e,e',e''):is) = s++"="++outputG e++":"++outputG e'++"; "++outputG e''++", "++showForall is 89 | 90 | showUse :: Uses p -> String 91 | showUse (UseNil _) = "" 92 | showUse (Use _ (n, []) us _) = ((ind 1)++"use "++n++"\n") ++ (showUse us) 93 | showUse (Use _ (n, renames) us _) = ((ind 1)++"use "++n++", " ++ 94 | (concat $ intersperse ", " (map (\(a, b) -> a ++ " => " ++ b) renames)) ++ 95 | "\n") ++ (showUse us) 96 | 97 | -- Printing declarations 98 | -- 99 | instance (OutputG (Arg p) v, 100 | OutputG (BaseType p) v, 101 | OutputG (Block p) v, 102 | OutputG (Decl p) v, 103 | OutputG (Fortran p) v, 104 | OutputG (Implicit p) v, 105 | OutputG (SubName p) v, 106 | OutputG (VarName p) v, 107 | OutputG (ProgUnit p) v, 108 | Alts v) => OutputF (ProgUnit p) v where 109 | outputF (Sub _ _ (Just p) n a b) = outputG p ++ " subroutine "++(outputG n)++outputG a++"\n"++ 110 | outputG b++ 111 | "\nend subroutine "++(outputG n)++"\n" 112 | outputF (Sub _ _ Nothing n a b) = "subroutine "++(outputG n)++outputG a++"\n"++ 113 | outputG b++ 114 | "\nend subroutine "++(outputG n)++"\n" 115 | outputF (Function _ _ (Just p) n a (Just r) b) = outputG p ++ " function "++(outputG n)++outputG a++" result("++outputG r++")\n"++ 116 | outputG b++ 117 | "\nend function "++(outputG n)++"\n" 118 | outputF (Function _ _ (Just p) n a Nothing b) = outputG p ++ " function "++(outputG n)++outputG a++"\n"++ 119 | outputG b++ 120 | "\nend function "++(outputG n)++"\n" 121 | outputF (Function _ _ Nothing n a (Just r) b) = "function "++(outputG n)++outputG a++" result("++outputG r++")\n"++ 122 | outputG b++ 123 | "\nend function "++(outputG n)++"\n" 124 | outputF (Function _ _ Nothing n a Nothing b) = "function "++(outputG n)++outputG a++"\n"++ 125 | outputG b++ 126 | "\nend function "++(outputG n)++"\n" 127 | outputF (Main _ _ n a b []) = "program "++(outputG n) ++ 128 | (if not (isEmptyArg a) then (outputG a) else ""++"\n") ++ 129 | outputG b ++ 130 | "\nend program "++ (outputG n) ++"\n" 131 | outputF (Main _ _ n a b ps) = "program "++(outputG n) ++ 132 | (if not (isEmptyArg a) then (outputG a) else ""++"\n") ++ 133 | outputG b ++ 134 | "\ncontains\n" ++ 135 | (concatMap outputG ps) ++ 136 | "\nend program "++(outputG n)++"\n" 137 | 138 | outputF (Module _ _ n us i ds []) = "module "++(outputG n)++"\n" ++ 139 | showUse us ++ 140 | outputG i ++ 141 | outputG ds ++ 142 | "end module " ++ (outputG n)++"\n" 143 | outputF (Module _ _ n us i ds ps) = "module "++(outputG n)++"\n" ++ 144 | showUse us ++ 145 | outputG i ++ 146 | outputG ds ++ 147 | "\ncontains\n" ++ 148 | concatMap outputG ps ++ 149 | "end module " ++ (outputG n)++"\n" 150 | outputF (BlockData _ _ n us i ds) = "block data " ++ (outputG n) ++ "\n" ++ 151 | showUse us ++ 152 | outputG i ++ 153 | outputG ds ++ 154 | "end block data " ++ (outputG n)++"\n" 155 | outputF (PSeq _ _ p p') = outputG p++outputG p' 156 | outputF (Prog _ _ p) = outputG p 157 | outputF (NullProg _ _) = "" 158 | outputF (IncludeProg _ _ ds Nothing) = outputG ds 159 | outputF (IncludeProg _ _ ds (Just f)) = outputG ds ++ "\n" ++ outputG f 160 | 161 | instance (OutputG (Fortran p) v, OutputG (Decl p) v, OutputG (Implicit p) v, Alts v) => 162 | OutputF (Block p) v where 163 | outputF (Block _ (UseBlock us _) i sp ds f) = showUse us++outputG i++(outputG ds)++outputG f 164 | 165 | 166 | instance (OutputG (Expr p) v) => OutputF (DataForm p) v where 167 | outputF (Data _ ds) = "data "++(concat (intersperse "\n" (map show_data ds))) 168 | 169 | instance (Indentor (Decl p), 170 | OutputG (ArgList p) v, 171 | OutputG (Attr p) v, 172 | OutputG (BinOp p) v, 173 | OutputG (Decl p) v, 174 | OutputG (DataForm p) v, 175 | OutputG (Expr p) v, 176 | OutputG (GSpec p) v, 177 | OutputG (InterfaceSpec p) v, 178 | OutputG (MeasureUnitSpec p) v, 179 | OutputG (SubName p) v, 180 | OutputG (UnaryOp p) v, 181 | OutputG (VarName p) v, 182 | OutputG (Type p) v, 183 | Alts v) => OutputF (Decl p) v where 184 | outputF x@(Decl _ _ vs t) = (indR x 1)++outputG t++" :: "++asSeq id (map showDV vs)++"\n" 185 | outputF (Namelist _ ns) = ind 1++"namelist "++show_namelist ns++"\n" 186 | outputF (DataDecl _ ds) = ind 1++ (outputG ds) ++"\n" 187 | outputF t@(Equivalence _ _ vs) = (indR t 1)++"equivlance ("++(concat (intersperse "," (map outputF vs))) ++ ")\n" 188 | outputF (AttrStmt _ p gs) = ind 1++outputG p ++ " (" ++asSeq id (map showDV gs) ++ ") \n" 189 | outputF (AccessStmt _ p []) = ind 1++outputG p ++ "\n" 190 | outputF (AccessStmt _ p gs) = ind 1++outputG p ++ " :: " ++ (concat . intersperse ", " . map outputG) gs++"\n" 191 | outputF (ExternalStmt _ xs) = ind 1++"external :: " ++ (concat (intersperse "," xs)) ++ "\n" 192 | outputF (Interface _ (Just g) is) = ind 1 ++ "interface " ++ outputG g ++ outputG is ++ ind 1 ++ "end interface" ++ outputG g ++ "\n" 193 | outputF (Common _ _ name exps) = ind 1++"common " ++ (case name of 194 | Just n -> "/" ++ n ++ "/ " 195 | Nothing -> "") ++ (concat (intersperse "," (map outputF exps))) ++ "\n" 196 | outputF (Interface _ Nothing is) = ind 1 ++ "interface " ++ outputG is ++ ind 1 ++ "end interface\n" 197 | outputF (DerivedTypeDef _ _ n as ps ds) = ind 1 ++ "type " ++ outputFList as ++ " :: " ++ outputG n ++ "\n" ++ (concat (intersperse "\n" (map (outputG) ps))) ++ (if (length ps > 0) then "\n" else "") ++ (concatMap (((ind 2) ++) . outputG) ds) ++ ind 1 ++ "end type " ++ outputG n ++ "\n\n" 198 | outputF (MeasureUnitDef _ _ ds) = ind 1 ++ "unit :: " ++ (concat . intersperse ", " . map showDU) ds ++ "\n" 199 | outputF (Include _ i) = "include "++outputG i 200 | outputF (DSeq _ d d') = outputG d++outputG d' 201 | outputF (NullDecl _ _) = "" 202 | 203 | show_namelist ((x,xs):[]) = "/" ++ outputG x ++ "/" ++ (concat (intersperse ", " (map outputG xs))) 204 | show_namelist ((x,xs):ys) = "/" ++ outputG x ++ "/" ++ (concat (intersperse ", " (map outputG xs))) ++ "," ++ show_namelist ys 205 | show_data ((xs,ys)) = "/" ++ outputG xs ++ "/" ++ outputG ys 206 | 207 | -- showDV :: (Expr,Expr) -> String 208 | 209 | showDV (v, NullExpr _ _, Just n) = (outputF v) ++ "*" ++ show n 210 | showDV (v, NullExpr _ _, Nothing) = outputF v 211 | showDV (v,e,Nothing) = outputF v++" = "++outputF e 212 | showDV (v,e,Just n) = (outputF v) ++ "*" ++ show n ++ " = "++(outputF e) 213 | 214 | showDU (name,spec) = outputF name++" = "++outputF spec 215 | 216 | instance (OutputG (ArgList p) v, 217 | OutputG (BinOp p) v, 218 | OutputG (UnaryOp p) v, 219 | OutputG (BaseType p) v, 220 | OutputG (Expr p) v, 221 | OutputG (MeasureUnitSpec p) v, 222 | OutputG (VarName p) v, 223 | Alts v) => OutputF (Type p) v where 224 | outputF (BaseType _ bt as (NullExpr _ _) (NullExpr _ _)) = outputG bt++outputFList as 225 | outputF (BaseType _ bt as (NullExpr _ _) e') = outputG bt++" (len="++outputG e'++")"++outputFList as 226 | outputF (BaseType _ bt as e (NullExpr _ _)) = outputG bt++" (kind="++outputG e++")"++outputFList as 227 | outputF (BaseType _ bt as e e') = outputG bt++" (len="++outputG e'++"kind="++outputG e++")"++outputFList as 228 | outputF (ArrayT _ [] bt as (NullExpr _ _) (NullExpr _ _)) = outputG bt++outputFList as 229 | outputF (ArrayT _ [] bt as (NullExpr _ _) e') = outputG bt++" (len="++outputG e'++")"++outputFList as 230 | outputF (ArrayT _ [] bt as e (NullExpr _ _)) = outputG bt++" (kind="++outputG e++")"++outputFList as 231 | outputF (ArrayT _ [] bt as e e') = outputG bt++" (len="++outputG e'++"kind="++outputG e++")"++outputFList as 232 | outputF (ArrayT _ rs bt as (NullExpr _ _) (NullExpr _ _)) = outputG bt++" , dimension ("++showRanges rs++")"++outputFList as 233 | outputF (ArrayT _ rs bt as (NullExpr _ _) e') = outputG bt++" (len="++outputG e'++")"++" , dimension ("++showRanges rs++")"++outputFList as 234 | outputF (ArrayT _ rs bt as e (NullExpr _ _)) = outputG bt++" (kind="++outputG e++")"++" , dimension ("++showRanges rs++")"++outputFList as 235 | outputF (ArrayT _ rs bt as e e') = outputG bt++" (len="++outputG e'++"kind="++outputG e++")"++" , dimension ("++showRanges rs++")"++outputFList as 236 | 237 | 238 | instance (OutputG (ArgList p) v, OutputG (BinOp p) v, OutputG (Expr p) v, OutputG (UnaryOp p) v, 239 | OutputG (VarName p) v, 240 | OutputG (MeasureUnitSpec p) v, Alts v) => OutputF (Attr p) v where --new 241 | outputF (Allocatable _) = "allocatable " 242 | outputF (Parameter _) = "parameter " 243 | outputF (External _) = "external " 244 | outputF (Intent _ (In _)) = "intent(in) " 245 | outputF (Intent _ (Out _)) = "intent(out) " 246 | outputF (Intent _ (InOut _)) = "intent(inout) " 247 | outputF (Intrinsic _) = "intrinsic " 248 | outputF (Optional _) = "optional " 249 | outputF (Pointer _) = "pointer " 250 | outputF (Save _) = "save " 251 | outputF (Target _) = "target " 252 | outputF (Volatile _) = "volatile " 253 | outputF (Public _) = "public " 254 | outputF (Private _) = "private " 255 | outputF (Sequence _) = "sequence " 256 | outputF (Dimension _ r) = "dimension (" ++ (showRanges r) ++ ")" 257 | outputF (MeasureUnit _ u) = "unit("++outputG u++")" 258 | 259 | instance (Alts v) => OutputF (MeasureUnitSpec p) v where 260 | outputF (UnitProduct _ units) = showUnits units 261 | outputF (UnitQuotient _ units1 units2) = showUnits units1++" / "++showUnits units2 262 | outputF (UnitNone _) = "" 263 | 264 | instance (Alts v) => OutputF (Fraction p) v where 265 | outputF (IntegerConst _ s) = "**"++outputG s 266 | outputF (FractionConst _ p q) = "**("++outputG p++"/"++outputG q++")" 267 | outputF (NullFraction _) = "" 268 | 269 | instance (OutputG (Arg p) v, OutputG (BinOp p) v, OutputG (Expr p) v, Alts v) => OutputF (GSpec p) v where 270 | outputF (GName _ s) = outputG s 271 | outputF (GOper _ op) = "operator("++outputG op++")" 272 | outputF (GAssg _) = "assignment(=)" 273 | 274 | instance (OutputG (Arg p) v, OutputG (Decl p) v, OutputG (Implicit p) v, 275 | OutputG (SubName p) v, Alts v) => OutputF (InterfaceSpec p) v where 276 | outputF (FunctionInterface _ s as us i ds) = (ind 1)++ "function " ++ outputG s ++ outputG as ++ showUse us ++ outputG i ++ outputG ds ++ "\nend function " ++ outputG s 277 | outputF (SubroutineInterface _ s as us i ds) = (ind 1)++ "subroutine " ++ outputG s ++ outputG as ++ showUse us ++ outputG i ++ outputG ds ++ "\nend subroutine " ++ outputG s 278 | outputF (ModuleProcedure _ ss) = (ind 2) ++ "module procedure " ++ concat (intersperse ", " (map (outputG) ss)) 279 | 280 | instance (Alts v, OutputF (Uses p) v) => OutputF (UseBlock p) v where 281 | outputF (UseBlock uses _) = outputF uses 282 | 283 | instance (Alts v) => OutputF (Uses p) v where 284 | outputF u = showUse u 285 | 286 | instance (OutputG (SubName p) v, Alts v) => OutputF (BaseType p) v where 287 | outputF (Integer _) = "integer" 288 | outputF (Real _) = "real" 289 | outputF (Character _) = "character" 290 | outputF (Logical _) = "logical" 291 | outputF (DerivedType _ s) = "type ("++outputG s++")" 292 | outputF (SomeType _) = error "sometype not valid in output source file" 293 | 294 | -- Printing statements and expressions 295 | -- 296 | instance (OutputG (ArgList p) v, 297 | OutputG (BinOp p) v, 298 | OutputG (Expr p) v, 299 | OutputG (UnaryOp p) v, 300 | OutputG (VarName p) v, 301 | Alts v) => OutputF (Expr p) v where 302 | outputF (Con _ _ i) = i 303 | outputF (ConL _ _ m s) = m:("\'" ++ s ++ "\'") 304 | outputF (ConS _ _ s) = s 305 | outputF (Var _ _ vs) = showPartRefList vs 306 | outputF (Bin _ _ bop e@(Bin _ _ op _ _ ) e'@(Bin _ _ op' _ _)) = checkPrec bop op (paren) (outputG e)++outputG bop++ checkPrec bop op' (paren) (outputG e') 307 | outputF (Bin _ _ bop e@(Bin _ _ op _ _) e') = checkPrec bop op (paren) (outputG e)++outputG bop++outputG e' 308 | outputF (Bin _ _ bop e e'@(Bin _ _ op' _ _)) = outputG e++outputG bop++checkPrec bop op' (paren) (outputG e') 309 | outputF (Bin _ _ bop e e') = outputG e++outputG bop++outputG e' 310 | outputF (Unary _ _ uop e) = "("++outputG uop++outputG e++")" 311 | outputF (CallExpr _ _ s as) = outputG s ++ outputG as 312 | outputF (Null _ _) = "NULL()" 313 | outputF (NullExpr _ _) = "" 314 | outputF (ESeq _ _ (NullExpr _ _) e) = outputG e 315 | outputF (ESeq _ _ e (NullExpr _ _)) = outputG e 316 | outputF (ESeq _ _ e e') = outputG e++","++outputG e' 317 | outputF (Bound _ _ e e') = outputG e++":"++outputG e' 318 | outputF (Sqrt _ _ e) = "sqrt("++outputG e++")" 319 | outputF (ArrayCon _ _ es) = "(\\" ++ concat (intersperse ", " (map (outputG) es)) ++ "\\)" 320 | outputF (AssgExpr _ _ v e) = v ++ "=" ++ outputG e 321 | 322 | instance (OutputIndF (Fortran p) v, Alts v) => OutputF (Fortran p) v where 323 | outputF = outputIndF 1 324 | 325 | instance (OutputG (ArgName p) v, Alts v) => OutputF (Arg p) v where 326 | outputF (Arg _ vs _) = "("++ outputG vs ++")" 327 | 328 | instance (OutputG (Expr p) v, Alts v) => OutputF (ArgList p) v where 329 | outputF (ArgList _ es) = "("++outputG es++")" -- asTuple outputG es 330 | 331 | instance Alts v => OutputF (BinOp p) v where 332 | outputF (Plus _) ="+" 333 | outputF (Minus _) ="-" 334 | outputF (Mul _) ="*" 335 | outputF (Div _) ="/" 336 | outputF (Or _) =".or." 337 | outputF (And _) =".and." 338 | outputF (Concat _) ="//" 339 | outputF (Power _) ="**" 340 | outputF (RelEQ _) ="==" 341 | outputF (RelNE _) ="/=" 342 | outputF (RelLT _) ="<" 343 | outputF (RelLE _) ="<=" 344 | outputF (RelGT _) =">" 345 | outputF (RelGE _) =">=" 346 | 347 | instance Alts v => OutputF (UnaryOp p) v where 348 | outputF (UMinus _) = "-" 349 | outputF (Not _) = ".not." 350 | 351 | instance Alts v => OutputF (VarName p) v where 352 | outputF (VarName _ v) = v 353 | 354 | instance (OutputG (VarName p) v, OutputG (ArgName p) v, Alts v) => OutputF (ArgName p) v where 355 | outputF (ArgName _ a) = a 356 | outputF (ASeq _ (NullArg _) (NullArg _)) = "" 357 | outputF (ASeq _ (NullArg _) a') = outputG a' 358 | outputF (ASeq _ a (NullArg _)) = outputG a 359 | outputF (ASeq _ a a') = outputG a++","++outputG a' 360 | outputF (NullArg _) = "" 361 | 362 | instance Alts v => OutputF (SubName p) v where 363 | outputF (SubName _ n) = n 364 | outputF (NullSubName _) = error "subroutine needs a name" 365 | 366 | instance Alts v => OutputF ( Implicit p) v where 367 | outputF (ImplicitNone _) = " implicit none\n" 368 | outputF (ImplicitNull _) = "" 369 | 370 | instance (OutputG (Expr p) v, Alts v) => OutputF (Spec p) v where 371 | outputF (Access _ s) = "access = " ++ outputG s 372 | outputF (Action _ s) = "action = "++outputG s 373 | outputF (Advance _ s) = "advance = "++outputG s 374 | outputF (Blank _ s) = "blank = "++outputG s 375 | outputF (Delim _ s) = "delim = "++outputG s 376 | outputF (Direct _ s) = "direct = "++outputG s 377 | outputF (End _ s) = "end = "++outputG s 378 | outputF (Eor _ s) = "eor = "++outputG s 379 | outputF (Err _ s) = "err = "++outputG s 380 | outputF (Exist _ s) = "exist = "++outputG s 381 | outputF (File _ s) = "file = "++outputG s 382 | outputF (FMT _ s) = "fmt = "++outputG s 383 | outputF (Form _ s) = "form = "++outputG s 384 | outputF (Formatted _ s) = "formatted = "++outputG s 385 | outputF (Unformatted _ s) = "unformatted = "++outputG s 386 | outputF (IOLength _ s) = "iolength = "++outputG s 387 | outputF (IOStat _ s) = "iostat = "++outputG s 388 | outputF (Opened _ s) = "opened = "++outputG s 389 | outputF (Name _ s) = "name = "++outputG s 390 | outputF (Named _ s) = "named = "++outputG s 391 | outputF (NextRec _ s) = "nextrec = "++outputG s 392 | outputF (NML _ s) = "nml = "++outputG s 393 | outputF (NoSpec _ s) = outputG s 394 | outputF (Floating _ s1 s2) = outputG s1 ++ "F" ++ outputG s2 395 | outputF (Number _ s) = "number = "++outputG s 396 | outputF (Pad _ s) = "pad = "++outputG s 397 | outputF (Position _ s) = "position = "++outputG s 398 | outputF (Read _ s) = "read = "++outputG s 399 | outputF (ReadWrite _ s) = "readwrite = "++outputG s 400 | outputF (WriteSp _ s) = "write = "++outputG s 401 | outputF (Rec _ s) = "rec = "++outputG s 402 | outputF (Recl _ s) = "recl = "++outputG s 403 | outputF (Sequential _ s) = "sequential = "++outputG s 404 | outputF (Size _ s) = "size = "++outputG s 405 | outputF (Status _ s) = "status = "++outputG s 406 | outputF (StringLit _ s) = "'" ++ s ++ "'" 407 | outputF (Unit _ s) = "unit = "++outputG s 408 | outputF (Delimiter _) = "/" 409 | 410 | 411 | 412 | 413 | isEmptyArg (Arg _ as _) = and (isEmptyArgName as) 414 | isEmptyArgName (ASeq _ a a') = isEmptyArgName a ++ isEmptyArgName a' 415 | isEmptyArgName (ArgName _ a) = [False] 416 | isEmptyArgName (NullArg _) = [True] 417 | 418 | paren :: String -> String 419 | paren s = "(" ++ s ++ ")" 420 | 421 | checkPrec :: BinOp p -> BinOp p -> (a -> a) -> a -> a 422 | checkPrec pop cop f s = if opPrec pop >= opPrec cop then f s else s 423 | 424 | opPrec :: BinOp p -> Int 425 | opPrec (Or _) = 0 426 | opPrec (And _) = 1 427 | opPrec (RelEQ _) = 2 428 | opPrec (RelNE _) = 2 429 | opPrec (RelLT _) = 2 430 | opPrec (RelLE _) = 2 431 | opPrec (RelGT _) = 2 432 | opPrec (RelGE _) = 2 433 | opPrec (Concat _) = 3 434 | opPrec (Plus _) = 4 435 | opPrec (Minus _) = 4 436 | opPrec (Mul _) = 5 437 | opPrec (Div _) = 5 438 | opPrec (Power _) = 6 439 | 440 | class Indentor t where 441 | indR :: t -> Int -> String 442 | 443 | instance (Indentor (Fortran p), 444 | OutputG (VarName p) v, 445 | OutputG (Expr p) v, 446 | OutputG (UnaryOp p) v, 447 | OutputG (BinOp p) v, 448 | OutputG (ArgList p) v, 449 | OutputIndG (Fortran p) v, 450 | OutputG (DataForm p) v, 451 | OutputG (Fortran p) v, OutputG (Spec p) v, Alts v) => OutputIndF (Fortran p) v where 452 | 453 | outputIndF i t@(Assg _ _ v e) = (indR t i)++outputG v++" = "++outputG e 454 | outputIndF i t@(DoWhile _ _ e f) = (indR t i)++"do while (" ++ outputG e ++ ")\n" ++ 455 | outputIndG (i+1) f ++ "\n" ++ (indR t i) ++ "end do" 456 | outputIndF i t@(For _ _ (VarName _ "") e e' e'' f) = (indR t i)++"do \n"++ 457 | (outputIndG (i+1) f)++"\n"++(indR t i)++"end do" 458 | outputIndF i t@(For _ _ v e e' e'' f) = (indR t i)++"do"++" "++outputG v++" = "++outputG e++", "++ 459 | outputG e'++", "++outputG e''++"\n"++ 460 | (outputIndG (i+1) f)++"\n"++(indR t i)++"end do" 461 | outputIndF i t@(FSeq _ _ f f') = outputIndG i f++"\n"++outputIndG i f' 462 | outputIndF i t@(If _ _ e f [] Nothing) = (indR t i)++"if ("++outputG e++") then\n" 463 | ++(outputIndG (i+1) f)++"\n" 464 | ++(indR t i)++"end if" 465 | outputIndF i t@(If _ _ e f [] (Just f')) = (indR t i)++"if ("++outputG e++") then\n" 466 | ++(outputIndG (i+1) f)++"\n" 467 | ++(indR t i)++"else\n" 468 | ++(outputIndG (i+1) f')++"\n" 469 | ++(indR t i)++"end if" 470 | outputIndF i t@(If _ _ e f elsif Nothing) = (indR t i)++"if ("++outputG e++") then\n" 471 | ++(outputIndG (i+1) f)++"\n" 472 | ++concat (map (showElseIf i) elsif) 473 | ++(indR t i)++"end if" 474 | outputIndF i t@(If _ _ e f elsif (Just f')) = (indR t i)++"if ("++outputG e++") then\n" 475 | ++(outputIndG (i+1) f)++"\n" 476 | ++concat (map (showElseIf i) elsif) 477 | ++(indR t i)++"else\n" 478 | ++(outputIndG (i+1) f')++"\n" 479 | ++(indR t i)++"end if" 480 | outputIndF i t@(Allocate _ _ a (NullExpr _ _)) = (indR t i)++"allocate (" ++ outputG a ++ ")" 481 | outputIndF i t@(Allocate _ _ a s) = (indR t i)++"allocate ("++ outputG a ++ ", STAT = "++outputG s++ ")" 482 | outputIndF i t@(Backspace _ _ ss) = (indR t i)++"backspace "++asTuple outputG ss++"\n" 483 | outputIndF i t@(Call _ _ sub al) = indR t i++"call "++outputG sub++outputG al 484 | outputIndF i t@(Open _ _ s) = (indR t i)++"open "++asTuple outputG s++"\n" 485 | 486 | outputIndF i t@(Close _ _ ss) = (indR t i)++"close "++asTuple outputG ss++"\n" 487 | outputIndF i t@(Continue _ _) = (indR t i)++"continue"++"\n" 488 | outputIndF i t@(Cycle _ _ s) = (indR t i)++"cycle "++outputG s++"\n" 489 | outputIndF i t@(DataStmt _ _ d) = (indR t i)++(outputG d)++"\n" 490 | outputIndF i t@(Deallocate _ _ es e) = (indR t i)++"deallocate "++asTuple outputG es++outputG e++"\n" 491 | outputIndF i t@(Endfile _ _ ss) = (indR t i)++"endfile "++asTuple outputG ss++"\n" 492 | outputIndF i t@(Exit _ _ s) = (indR t i)++"exit "++outputG s 493 | outputIndF i t@(Format _ _ es) = (indR t i)++"format " ++ (asTuple outputG es) 494 | outputIndF i t@(Forall _ _ (is, (NullExpr _ _)) f) = (indR t i)++"forall ("++showForall is++") "++outputG f 495 | outputIndF i t@(Forall _ _ (is,e) f) = (indR t i)++"forall ("++showForall is++","++outputG e++") "++outputG f 496 | outputIndF i t@(Goto _ _ s) = (indR t i)++"goto "++outputG s 497 | outputIndF i t@(Nullify _ _ es) = (indR t i)++"nullify "++asTuple outputG es++"\n" 498 | outputIndF i t@(Inquire _ _ ss es) = (indR t i)++"inquire "++asTuple outputG ss++" "++(concat (intersperse "," (map outputG es)))++"\n" 499 | outputIndF i t@(Pause _ _ s) = (indR t i)++"pause "++ show s ++ "\n" 500 | outputIndF i t@(Rewind _ _ ss) = (indR t i)++"rewind "++asTuple outputG ss++"\n" 501 | outputIndF i t@(Stop _ _ e) = (indR t i)++"stop "++outputG e++"\n" 502 | outputIndF i t@(Where _ _ e f Nothing) = (indR t i)++"where ("++outputG e++") "++outputG f 503 | outputIndF i t@(Where _ _ e f (Just f')) = (indR t i)++"where ("++outputG e++") "++(outputIndG (i + 1) f)++"\n"++(indR t i)++"elsewhere\n" ++ (indR t i) ++ (outputIndG (i + 1) f') ++ "\n" ++ (indR t i) ++ "end where" 504 | outputIndF i t@(Write _ _ ss es) = (indR t i)++"write "++asTuple outputG ss++" "++(concat (intersperse "," (map outputG es)))++"\n" 505 | outputIndF i t@(PointerAssg _ _ e e') = (indR t i)++outputG e++" => "++outputG e'++"\n" 506 | outputIndF i t@(Return _ _ e) = (indR t i)++"return "++outputG e++"\n" 507 | outputIndF i t@(Label _ _ s f) = s++" "++outputG f 508 | outputIndF i t@(Print _ _ e []) = (indR t i)++("print ")++outputG e++("\n") 509 | outputIndF i t@(Print _ _ e es) = (indR t i)++("print ")++outputG e++", "++(concat (intersperse "," (map outputG es)))++("\n") 510 | outputIndF i t@(ReadS _ _ ss es) = (indR t i)++("read ")++(asTuple outputG ss)++" "++(concat (intersperse "," (map outputG es)))++("\n") 511 | outputIndF i t@(NullStmt _ _) = "" 512 | 513 | -- infix 7 $+ 514 | -- infix 7 $- 515 | -- infix 8 $* 516 | -- infix 9 $/ 517 | 518 | ---------------------------------------------------------------------- 519 | -- PRINT UTILITIES 520 | ---------------------------------------------------------------------- 521 | 522 | showNQ :: Show a => a -> String 523 | showNQ = filter ('"'/=) . show 524 | 525 | -- Indenting 526 | 527 | ind = indent 3 528 | indent i l = take (i*l) (repeat ' ') 529 | 530 | 531 | printList sep f xs = sep!!0++concat (intersperse (sep!!1) (map f xs))++sep!!2 532 | 533 | asTuple = printList ["(",",",")"] 534 | asSeq = printList ["",",",""] 535 | asList = printList ["[",",","]"] 536 | asSet = printList ["{",",","}"] 537 | asLisp = printList ["("," ",")"] 538 | asPlain f xs = if null xs then "" else printList [" "," ",""] f xs 539 | asPlain' f xs = if null xs then "" else printList [""," ",""] f xs 540 | asCases l = printList ["\n"++ind++" ","\n"++ind++" | ",""] where ind = indent 4 l 541 | asDefs n = printList ["\n"++n,"\n"++n,"\n"] 542 | asParagraphs = printList ["\n","\n\n","\n"] 543 | 544 | -- Auxiliary functions 545 | -- 546 | optTuple :: (?variant :: v, Alts v, OutputG (UnaryOp p) v, OutputF (Expr p) v) => [Expr p] -> String 547 | optTuple [] = "" 548 | optTuple xs = asTuple outputF xs 549 | -- *optTuple xs = "" 550 | -- indent and showInd enable indented printing 551 | -- 552 | 553 | showUnits :: (Alts v, ?variant :: v, OutputF (Fraction p) v) => [(MeasureUnit, Fraction p)] -> String 554 | showUnits units 555 | | null units = "1" 556 | | otherwise = printList [""," ",""] (\(unit, f) -> unit++outputF f) units 557 | 558 | 559 | outputFList :: (Alts v, ?variant :: v, OutputF a v) => [a] -> String 560 | outputFList = concat . map (", "++) . map (outputF) 561 | 562 | 563 | 564 | showBounds :: (Alts v, ?variant :: v, OutputF (Expr p) v) => (Expr p,Expr p) -> String 565 | showBounds (NullExpr _ _, NullExpr _ _) = ":" 566 | showBounds (NullExpr _ _, e) = outputF e 567 | showBounds (e1,e2) = outputF e1++":"++outputF e2 568 | 569 | showRanges :: (Alts v, ?variant :: v, OutputF (Expr p) v) => [(Expr p, Expr p)] -> String 570 | showRanges = asSeq showBounds 571 | 572 | showPartRefList :: (Alts v, ?variant :: v, OutputG (VarName p) v, 573 | OutputG (UnaryOp p) v, OutputF (Expr p) v) => [(VarName p,[Expr p])] -> String 574 | showPartRefList [] = "" 575 | showPartRefList ((v,es):[]) = outputG v ++ optTuple es 576 | showPartRefList ((v,es):xs) = outputG v ++ optTuple es ++ "%" ++ showPartRefList xs -------------------------------------------------------------------------------- /src/LexerTest.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Applicative 4 | import Data.Char 5 | 6 | import Language.Fortran.Lexer 7 | import Language.Haskell.ParseMonad 8 | 9 | 10 | main :: IO () 11 | main = do 12 | s <- map toLower <$> getContents 13 | print (alexScanTokens s) 14 | -------------------------------------------------------------------------------- /src/ParserTest.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Language.Fortran.Parser 4 | 5 | main :: IO () 6 | main = return () -- TODO 7 | 8 | parseTest s = do f <- readFile s 9 | return $ parse f 10 | -------------------------------------------------------------------------------- /test.f90: -------------------------------------------------------------------------------- 1 | program testdo 2 | implicit none 3 | integer i 4 | integer j 5 | 6 | do 821 kp = 1, nplots 7 | do 822 ksp = 1, nspp 8 | biompsp (kp, ksp) = 0.0 9 | 822 continue 10 | 821 continue 11 | 12 | do 15 j=1,5 13 | do 17 i=1, 42 14 | print *,i 15 | 17 continue 16 | 15 continue 17 | 18 | end program testdo 19 | --------------------------------------------------------------------------------