From d64c137956d7ad4fe23d210097f91fd0cb845688 Mon Sep 17 00:00:00 2001 From: Mistral Contrastin Date: Wed, 22 Jul 2015 15:33:35 +0100 Subject: [PATCH 01/20] Fix Fortran77 comment with a preprocessing stage Fortran77 programs can use '*', 'c', or 'C' in first column for comments. By adding a preprocessing stage I converted every line that starts with these characters to '!' comments. This solution would break badly intended modern Fortran code in free form if a keyword or identifier that starts with 'c' is used. --- language-fortran.cabal | 2 +- src/Language/Fortran/Lexer.x | 5 +++-- src/Language/Fortran/PreProcess.hs | 15 +++++++++++++-- 3 files changed, 17 insertions(+), 5 deletions(-) diff --git a/language-fortran.cabal b/language-fortran.cabal index a54ec43..eaace16 100644 --- a/language-fortran.cabal +++ b/language-fortran.cabal @@ -1,5 +1,5 @@ name: language-fortran -version: 0.3 +version: 0.3.1 synopsis: Fortran lexer and parser, language support, and extensions. description: Lexer and parser for Fortran roughly supporting standards from FORTRAN 77 to Fortran 2003 (but with some patches and rough edges). Also includes language extension support for units-of-measure typing. diff --git a/src/Language/Fortran/Lexer.x b/src/Language/Fortran/Lexer.x index e4ead35..15fcf85 100644 --- a/src/Language/Fortran/Lexer.x +++ b/src/Language/Fortran/Lexer.x @@ -57,7 +57,8 @@ $exponent_letter = [EeDd] tokens :- \n\# .* $ { \s -> Text s } - \n(C|c).*$ { \s -> ContLineAlt } -- Fortran 77 style comment + -- \n(C|c).*$ { \s -> ContLineAlt } -- Fortran 77 style comment + -- \n*.*$ { \s -> ContLineAlt } -- Fortran 77 style comment \n { \s -> NewLine } ($white # \n)+ ; "#" { \s -> Hash } @@ -219,4 +220,4 @@ lexer' = do s <- getInput ContLineAlt -> lexNewline >> (discard (len - 1)) >> lexer' ContLineWithComment -> lexNewline >> lexNewline >> (discard (len - 2)) >> lexer' _ -> (discard len) >> (return tok) -} \ No newline at end of file +} diff --git a/src/Language/Fortran/PreProcess.hs b/src/Language/Fortran/PreProcess.hs index 0bed210..d324e8b 100644 --- a/src/Language/Fortran/PreProcess.hs +++ b/src/Language/Fortran/PreProcess.hs @@ -135,8 +135,19 @@ parseExpr file input = x <- pre_parser [] return x -pre_process input = parseExpr "" input - +{- + - Change Fortran77 style C, c, and * comments to ! comments. + -} +processComments source = unlines $ map changeComment $ lines source + +changeComment original@(x:xs) + | x == 'c' = '!':xs + | x == 'C' = '!':xs + | x == '*' = '!':xs + | otherwise = original + +pre_process input = parseExpr "" (processComments input) + go filename = do args <- getArgs srcfile <- readFile filename return $ parseExpr filename srcfile From 2f8546d0b80cbbacce06885be3f90ae450a0fed7 Mon Sep 17 00:00:00 2001 From: Dominic Date: Mon, 27 Jul 2015 14:16:06 +0100 Subject: [PATCH 02/20] added pprint method --- src/Language/Fortran/Pretty.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/src/Language/Fortran/Pretty.hs b/src/Language/Fortran/Pretty.hs index a793e1e..2bda0b0 100644 --- a/src/Language/Fortran/Pretty.hs +++ b/src/Language/Fortran/Pretty.hs @@ -12,7 +12,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE OverlappingInstances, ConstraintKinds #-} module Language.Fortran.Pretty where @@ -20,6 +20,12 @@ import Language.Fortran import Debug.Trace import Data.List +-- | Core pretty-printing primitive +pprint :: PrettyPrintable t => t -> String +pprint = let ?variant = Alt1 in outputF + +-- TODO: More documentation on how this works + data Alt1 = Alt1 data Alt2 = Alt2 data Alt3 = Alt3 @@ -29,6 +35,9 @@ instance Alts Alt1 instance Alts Alt2 instance Alts Alt3 +-- Pretty printable types predicate (aliases the OutputF constraint) +type PrettyPrintable t = OutputF t Alt1 + --instance (OutputF (ProgUnit p) Alt1) => Show (ProgUnit p) where -- show p = let ?variant = Alt1 in outputF p From fe8677ee2bc5abfb3b79a5b848c3790c0c0b0772 Mon Sep 17 00:00:00 2001 From: Dominic Date: Mon, 27 Jul 2015 14:38:19 +0100 Subject: [PATCH 03/20] added default indentor --- src/Language/Fortran/Pretty.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Language/Fortran/Pretty.hs b/src/Language/Fortran/Pretty.hs index 2bda0b0..6a3eb7f 100644 --- a/src/Language/Fortran/Pretty.hs +++ b/src/Language/Fortran/Pretty.hs @@ -449,6 +449,12 @@ opPrec (Power _) = 6 class Indentor t where indR :: t -> Int -> String + +-- Default indenting for code straight out of the parser +instance Indentor (p ()) where + indR t i = ind i + + instance (Indentor (Fortran p), OutputG (VarName p) v, OutputG (Expr p) v, From 730b4f95c20b2541a56baa404fd01782a63c4dca Mon Sep 17 00:00:00 2001 From: Mistral Contrastin Date: Mon, 27 Jul 2015 14:44:48 +0100 Subject: [PATCH 04/20] Add support for Double Precision data type Dobule precision implementation in the lexer and parser were commented out. Changed the keywords in lexer and added necessary data type in Fortran to successfully parse thme. --- src/Language/Fortran.hs | 3 ++- src/Language/Fortran/Lexer.x | 16 ++++++++-------- src/Language/Fortran/Parser.y | 10 +++++----- src/Language/Fortran/PreProcess.hs | 1 + src/Language/Fortran/Pretty.hs | 3 ++- 5 files changed, 18 insertions(+), 15 deletions(-) diff --git a/src/Language/Fortran.hs b/src/Language/Fortran.hs index 8048ba9..5a3880d 100644 --- a/src/Language/Fortran.hs +++ b/src/Language/Fortran.hs @@ -126,7 +126,8 @@ data Type p = BaseType p (BaseType p) [Attr p] (Expr p) ( | ArrayT p [(Expr p, Expr p)] (BaseType p) [Attr p] (Expr p) (Expr p) deriving (Show, Functor, Typeable, Data, Eq) -data BaseType p = Integer p | Real p | Character p | SomeType p | DerivedType p (SubName p) +data BaseType p = Integer p | Real p | DoublePrecision p | Character p + | SomeType p | DerivedType p (SubName p) | Recursive p | Pure p | Elemental p | Logical p | Complex p deriving (Show, Functor, Typeable, Data, Eq) diff --git a/src/Language/Fortran/Lexer.x b/src/Language/Fortran/Lexer.x index 3482962..95050db 100644 --- a/src/Language/Fortran/Lexer.x +++ b/src/Language/Fortran/Lexer.x @@ -119,9 +119,10 @@ tokens :- "{" { \s -> LBrace } "}" { \s -> RBrace } "else" @line_space "if" { \s -> Key "elseif" } - @name { \s -> if elem (map toLower s) keywords - then Key (map toLower s) - else ID s } + ("doubleprecision" | "double precision") { \s -> Key "double precision"} + @name { \s -> if (map toLower s) `elem` keywords + then Key (map toLower s) + else ID s } @data_edit_desc { \s -> DataEditDest s } @real_literal_constant { \s -> Num s } @@ -167,26 +168,25 @@ data Token = Key String | LitConst Char String | OpPower | OpMul | OpDiv | OpAdd | Hash | LBrace | RBrace | NewLine | TokEOF | Text String | ContLine | ContLineAlt | ContLineWithComment | ContLineNoNewLine deriving (Eq,Show) --- all reserved keywords, names are matched against these to see --- if they are keywords or IDs keywords :: [String] keywords = ["allocate", "allocatable","assign", "assignment","automatic","backspace","block","call", "case", "character","close","common","complex","contains","continue","cycle", "data","deallocate","default","dimension","do", - "double","elemental","else","elseif","elsewhere","end", "enddo", "endif", "endfile","entry", - "equivalence","exit","external", + "elemental","else","elseif","elsewhere","end", "enddo", "endif", + "endfile","entry", "equivalence","exit","external", "forall","format","function","goto","iolength", "if","implicit","in","include","inout","integer","intent","interface", "intrinsic","inquire","kind","len","logical","module", "namelist","none","nullify", "only","open","operator","optional","out","parameter", - "pause","pointer","precision","print","private","procedure", + "pause","pointer","print","private","procedure", "program","public","pure","real","read","recursive","result", "return","rewind","save","select","sequence","sometype","sqrt","stat", "stop","subroutine","target","to","then","type", "unit", "use","volatile","where","while","write"] + {- old keywords, many will be removed keywords :: [String] keywords = ["access","action","advance","allocate","allocatable","assign", diff --git a/src/Language/Fortran/Parser.y b/src/Language/Fortran/Parser.y index 6f6e40e..11f7dd4 100644 --- a/src/Language/Fortran/Parser.y +++ b/src/Language/Fortran/Parser.y @@ -100,7 +100,7 @@ import Debug.Trace -- DEFAULT { Key "default" } DIMENSION { Key "dimension" } DO { Key "do" } --- DOUBLE { Key "double" } + DOUBLE_PRECISION { Key "double precision" } ELEMENTAL { Key "elemental" } ELSE { Key "else" } ELSEIF { Key "elseif" } @@ -145,7 +145,6 @@ import Debug.Trace PARAMETER { Key "parameter" } PAUSE { Key "pause" } POINTER { Key "pointer" } --- PRECISION { Key "precision" } PRINT { Key "print" } PRIVATE { Key "private" } PROCEDURE { Key "procedure" } @@ -426,9 +425,9 @@ type_spec | REAL '*' length_value {% getSrcSpanNull >>= (\s -> return $ (Real (), $3, NullExpr () s)) } | REAL {% getSrcSpanNull >>= (\s -> return $ (Real (), NullExpr () s, NullExpr () s)) } | SOMETYPE {% getSrcSpanNull >>= (\s -> return $ (SomeType (), NullExpr () s, NullExpr () s)) } --- | DOUBLE PRECISION kind_selector { (Double (), $3, ne s)) } --- | DOUBLE PRECISION '*' length_value { (Double (), $4, ne s)) } --- | DOUBLE PRECISION { (Double (), ne s, ne s)) } +| DOUBLE_PRECISION kind_selector {% getSrcSpanNull >>= (\s -> return $ (DoublePrecision (), $2, NullExpr () s)) } +| DOUBLE_PRECISION '*' length_value {% getSrcSpanNull >>= (\s -> return $ (DoublePrecision (), $3, NullExpr () s)) } +| DOUBLE_PRECISION {% getSrcSpanNull >>= (\s -> return $ (DoublePrecision (), NullExpr () s, NullExpr () s)) } | COMPLEX kind_selector {% getSrcSpanNull >>= (\s -> return $ (Complex (), $2, NullExpr () s)) } | COMPLEX '*' length_value {% getSrcSpanNull >>= (\s -> return $ (Complex (), $3, NullExpr () s)) } | COMPLEX {% getSrcSpanNull >>= (\s -> return $ (Complex (),NullExpr () s, NullExpr () s)) } @@ -1015,6 +1014,7 @@ type_cast | INTEGER { "INTEGER" } | LOGICAL { "LOGICAL" } | CHARACTER { "CHARACTER" } + | DOUBLE_PRECISION { "DOUBLE PRECISION" } -- Bit of a conflict here- not entirely sure when this is needed diff --git a/src/Language/Fortran/PreProcess.hs b/src/Language/Fortran/PreProcess.hs index 2f2bbc8..c31b54c 100644 --- a/src/Language/Fortran/PreProcess.hs +++ b/src/Language/Fortran/PreProcess.hs @@ -143,6 +143,7 @@ processComments :: String -> String processComments source = unlines $ map changeComment $ lines source changeComment :: String -> String +changeComment "" = "" changeComment original@(x:xs) | x == 'c' = '!':xs | x == 'C' = '!':xs diff --git a/src/Language/Fortran/Pretty.hs b/src/Language/Fortran/Pretty.hs index 6a3eb7f..8a316c6 100644 --- a/src/Language/Fortran/Pretty.hs +++ b/src/Language/Fortran/Pretty.hs @@ -295,6 +295,7 @@ instance (Alts v) => OutputF (Uses p) v where instance (OutputG (SubName p) v, Alts v) => OutputF (BaseType p) v where outputF (Integer _) = "integer" outputF (Real _) = "real" + outputF (DoublePrecision _) = "double precision" outputF (Character _) = "character" outputF (Logical _) = "logical" outputF (DerivedType _ s) = "type ("++outputG s++")" @@ -588,4 +589,4 @@ showPartRefList :: (Alts v, ?variant :: v, OutputG (VarName p) v, OutputG (UnaryOp p) v, OutputF (Expr p) v) => [(VarName p,[Expr p])] -> String showPartRefList [] = "" showPartRefList ((v,es):[]) = outputG v ++ optTuple es -showPartRefList ((v,es):xs) = outputG v ++ optTuple es ++ "%" ++ showPartRefList xs \ No newline at end of file +showPartRefList ((v,es):xs) = outputG v ++ optTuple es ++ "%" ++ showPartRefList xs From cc0a54300a654c5a4bec69eb6b12e7c52ca91110 Mon Sep 17 00:00:00 2001 From: Mistral Contrastin Date: Mon, 27 Jul 2015 16:30:20 +0100 Subject: [PATCH 05/20] Handle fixed form Fortran continuation lines Fixed form Fortran (aka. 66/77) has continuation lines specified in column 6 of each lines by putting a character that is not ' ' or '0' these lines are supposed to be interpreted as part of the statement above. Since fixed form is not handled explicitly in current version of language-fortran, preprocessor takes these continuation lines and appends it to the end of the previous line before sending it to lexer. --- src/Language/Fortran/PreProcess.hs | 52 +++++++++++++++++++++++++++--- 1 file changed, 48 insertions(+), 4 deletions(-) diff --git a/src/Language/Fortran/PreProcess.hs b/src/Language/Fortran/PreProcess.hs index c31b54c..a07e93f 100644 --- a/src/Language/Fortran/PreProcess.hs +++ b/src/Language/Fortran/PreProcess.hs @@ -36,6 +36,7 @@ module Language.Fortran.PreProcess ( import Text.ParserCombinators.Parsec hiding (spaces) import System.Environment +import Debug.Trace num = many1 digit small = lower <|> char '_' @@ -145,13 +146,56 @@ processComments source = unlines $ map changeComment $ lines source changeComment :: String -> String changeComment "" = "" changeComment original@(x:xs) - | x == 'c' = '!':xs - | x == 'C' = '!':xs - | x == '*' = '!':xs + | isComment original = '!':xs | otherwise = original +isComment :: String -> Bool +isComment "" = False +isComment (f:_) + | f == 'c' = True + | f == 'C' = True + | f == '*' = True + | otherwise = False + +{- + - Old continuation used in fixed form Fortran are specified in column 6 + - and are in effect whenever the characeter is not ' ' or '0'. This processing + - stage connects those lines to the line before. + - + - If the continuation line has something else such as a label in its first + - 6 columns then an error is thrown. + -} +processOldContLines :: String -> String +processOldContLines source = unlines (eliminateContLines (lines source) 2) + +eliminateContLines :: [String] -> Integer -> [String] +eliminateContLines [] _ = [] +eliminateContLines [x] _ = [x] +eliminateContLines (l1:l2:rest) lineNumb + | length l2 <= 6 = l1:eliminateContLines (l2:rest) (lineNumb + 1) + | isContLine == False = l1:eliminateContLines (l2:rest) (lineNumb + 1) + | isComment l2 = l1:eliminateContLines (l2:rest) (lineNumb + 1) + | isContLine && isFirst5ColsEmpty = + eliminateContLines ((removeTrailingWhitespace l1 ++ (statement l2)):rest) + (lineNumb + 1) + | otherwise = error $ "Cannot preprocess continuation at line " ++ + show lineNumb + where + statement = (\s -> drop 6 s) + newLineNumb = lineNumb + 1 + first5Cols = take 5 l2 + col6 = l2 !! 5 + isContLine = col6 /= ' ' && col6 /= '0' + isFirst5ColsEmpty = first5Cols == " " + +removeTrailingWhitespace :: String -> String +removeTrailingWhitespace line = + reverse $ dropWhile (==' ') $ reverse line + pre_process :: String -> String -pre_process input = parseExpr "" (processComments input) +pre_process input = parseExpr "" + $ processComments + $ processOldContLines input go filename = do args <- getArgs srcfile <- readFile filename From cd12c7674d683c49d32f2e8e620fc3cab683852c Mon Sep 17 00:00:00 2001 From: Mistral Contrastin Date: Mon, 27 Jul 2015 16:41:39 +0100 Subject: [PATCH 06/20] Separate preprocessor interface from fixed form Now there is a new interface called pre_process_fixed_form that applies comment transformation and continuation line elimination on the input before parsing. --- src/Language/Fortran/PreProcess.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/Language/Fortran/PreProcess.hs b/src/Language/Fortran/PreProcess.hs index a07e93f..be94370 100644 --- a/src/Language/Fortran/PreProcess.hs +++ b/src/Language/Fortran/PreProcess.hs @@ -30,6 +30,7 @@ program is transformed to: -} module Language.Fortran.PreProcess ( pre_process + , pre_process_fixed_form , parseExpr ) where @@ -193,9 +194,12 @@ removeTrailingWhitespace line = reverse $ dropWhile (==' ') $ reverse line pre_process :: String -> String -pre_process input = parseExpr "" - $ processComments - $ processOldContLines input +pre_process input = parseExpr "" input + +pre_process_fixed_form input = + parseExpr "" + $ processComments + $ processOldContLines input go filename = do args <- getArgs srcfile <- readFile filename From 6c5a89fcfca997d33c73937a8e7f474d83486948 Mon Sep 17 00:00:00 2001 From: Dominic Date: Mon, 27 Jul 2015 18:19:20 +0100 Subject: [PATCH 07/20] refactoring outputF/outputG to printMaster/printSlave --- src/Language/Fortran.hs | 3 - src/Language/Fortran/Pretty.hs | 861 ++++++++++++++++----------------- 2 files changed, 418 insertions(+), 446 deletions(-) diff --git a/src/Language/Fortran.hs b/src/Language/Fortran.hs index 5a3880d..6d7f936 100644 --- a/src/Language/Fortran.hs +++ b/src/Language/Fortran.hs @@ -80,7 +80,6 @@ data ProgUnit p = Main p SrcSpan (SubName p) (Arg p) | Function p SrcSpan (Maybe (BaseType p)) (SubName p) (Arg p) (Maybe (VarName p)) (Block p) | Module p SrcSpan (SubName p) (Uses p) (Implicit p) (Decl p) [ProgUnit p] | BlockData p SrcSpan (SubName p) (Uses p) (Implicit p) (Decl p) - | PSeq p SrcSpan (ProgUnit p) (ProgUnit p) -- sequence of programs | Prog p SrcSpan (ProgUnit p) -- useful for {#p: #q : program ... } | NullProg p SrcSpan -- null | IncludeProg p SrcSpan (Decl p) (Maybe (Fortran p)) @@ -316,7 +315,6 @@ instance Span (ProgUnit a) where srcSpan (Function x sp _ _ _ _ _) = sp srcSpan (Module x sp _ _ _ _ _ ) = sp srcSpan (BlockData x sp _ _ _ _) = sp - srcSpan (PSeq x sp _ _) = sp srcSpan (Prog x sp _) = sp srcSpan (NullProg x sp) = sp @@ -435,7 +433,6 @@ instance Tagged ProgUnit where tag (Function x sp _ _ _ _ _)= x tag (Module x sp _ _ _ _ _ ) = x tag (BlockData x sp _ _ _ _) = x - tag (PSeq x sp _ _) = x tag (Prog x sp _) = x tag (NullProg x sp) = x diff --git a/src/Language/Fortran/Pretty.hs b/src/Language/Fortran/Pretty.hs index 8a316c6..d400368 100644 --- a/src/Language/Fortran/Pretty.hs +++ b/src/Language/Fortran/Pretty.hs @@ -1,18 +1,9 @@ -- -- Pretty.hs - -- Based on code by Martin Erwig from Parameterized Fortran --- - -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE OverlappingInstances, ConstraintKinds #-} +-- Fortran pretty printer + +{-# LANGUAGE ExistentialQuantification, FlexibleContexts, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, DeriveDataTypeable, QuasiQuotes, DeriveFunctor, ImplicitParams, OverlappingInstances, ConstraintKinds #-} module Language.Fortran.Pretty where @@ -22,402 +13,388 @@ import Data.List -- | Core pretty-printing primitive pprint :: PrettyPrintable t => t -> String -pprint = let ?variant = Alt1 in outputF - --- TODO: More documentation on how this works - -data Alt1 = Alt1 -data Alt2 = Alt2 -data Alt3 = Alt3 - -class Alts a -instance Alts Alt1 -instance Alts Alt2 -instance Alts Alt3 - --- Pretty printable types predicate (aliases the OutputF constraint) -type PrettyPrintable t = OutputF t Alt1 - ---instance (OutputF (ProgUnit p) Alt1) => Show (ProgUnit p) where --- show p = let ?variant = Alt1 in outputF p - -class OutputF t v where - outputF :: (?variant :: v) => t -> String +pprint = let ?variant = DefaultPP in printMaster -class OutputG t v where - outputG :: (?variant :: v) => t -> String +-- | Define default pretty-print version constructor +data DefaultPP = DefaultPP -- Default behaviour --- Default alt1 instance -instance (OutputF t Alt1) => OutputG t Alt1 where - outputG = outputF +-- | The set of all types which can be used to switch between pretty printer versions +class PPVersion a +instance PPVersion DefaultPP -instance Alts v => OutputG Char v where - outputG = show +-- Pretty printable types predicate (aliases the PrintMaster constraint) +type PrettyPrintable t = PrintMaster t DefaultPP -instance Alts v => OutputG String v where - outputG = id +-- | Master print behaviour +class PrintMaster t v where + printMaster :: (?variant :: v) => t -> String -instance (Alts v, OutputG a v, OutputG b v) => OutputG (a, b) v where - outputG (a, b) = "(" ++ outputG a ++ ", " ++ outputG b ++ ")" +-- | Slave print behaviour +class PrintSlave t v where + printSlave :: (?variant :: v) => t -> String -instance (Alts v, OutputG a v) => OutputG [a] v where - outputG xs = "[" ++ go xs ++ "]" where go [] = "" - go [x] = outputG x - go (x:xs) = outputG x ++ ", " ++ (go xs) +-- | Slave print-indenting behaviour +class PrintIndSlave t v where + printIndSlave :: (?variant :: v) => Int -> t -> String -instance (Alts v, OutputG a v) => OutputF [a] v where - outputF xs = "[" ++ go xs ++ "]" where go [] = "" - go [x] = outputG x - go (x:xs) = outputG x ++ ", " ++ (go xs) +-- | Master print-indenting behaviour +class PrintIndMaster t v where + printIndMaster :: (?variant :: v) => Int -> t -> String -class OutputIndF t v where - outputIndF :: (?variant :: v) => Int -> t -> String +-- Default slave behaviour +instance (PrintMaster t DefaultPP) => PrintSlave t DefaultPP where + printSlave = printMaster +instance (PrintIndMaster t DefaultPP) => PrintIndSlave t DefaultPP where + printIndSlave = printIndMaster -class OutputIndG t v where - outputIndG :: (?variant :: v) => Int -> t -> String +-- Behaviour's that all slaves must have i.e., for all versions v -instance (OutputIndF t Alt1) => OutputIndG t Alt1 where - outputIndG = outputIndF +instance PPVersion v => PrintSlave Char v where + printSlave = show +instance PPVersion v => PrintSlave String v where + printSlave = id --- Fortran pretty printer - ---showAllocate ((e,b):[]) = outputG e++"("++showRanges b++")" --new ---showAllocate ((e,b):as) = outputG e++"("++showRanges b++")"++", "++showAllocate as --new - - --- showElseIf :: Int -> (Expr,Fortran) -> String +instance (PPVersion v, PrintSlave a v, PrintSlave b v) => PrintSlave (a, b) v where + printSlave (a, b) = "(" ++ printSlave a ++ ", " ++ printSlave b ++ ")" -showElseIf i (e,f) = (ind i)++"else if ("++outputG e++") then\n"++(ind (i+1))++outputG f++"\n" +instance (PPVersion v, PrintSlave a v) => PrintSlave [a] v where + printSlave xs = "[" ++ (concat $ intersperse ", " (map printSlave xs)) ++ "]" -showForall [] = "error" -showForall ((s,e,e',NullExpr _ _):[]) = s++"="++outputG e++":"++outputG e' -showForall ((s,e,e',e''):[]) = s++"="++outputG e++":"++outputG e'++"; "++outputG e'' -showForall ((s,e,e',NullExpr _ _):is) = s++"="++outputG e++":"++outputG e'++", "++showForall is -showForall ((s,e,e',e''):is) = s++"="++outputG e++":"++outputG e'++"; "++outputG e''++", "++showForall is - -showUse :: Uses p -> String -showUse (UseNil _) = "" -showUse (Use _ (n, []) us _) = ((ind 1)++"use "++n++"\n") ++ (showUse us) -showUse (Use _ (n, renames) us _) = ((ind 1)++"use "++n++", " ++ - (concat $ intersperse ", " (map (\(a, b) -> a ++ " => " ++ b) renames)) ++ - "\n") ++ (showUse us) +-------------------------------------------------------------------------- -- Printing declarations --- -instance (OutputG (Arg p) v, - OutputG (BaseType p) v, - OutputG (Block p) v, - OutputG (Decl p) v, - OutputG (Fortran p) v, - OutputG (Implicit p) v, - OutputG (SubName p) v, - OutputG (VarName p) v, - OutputG (ProgUnit p) v, - Alts v) => OutputF (ProgUnit p) v where - outputF (Sub _ _ (Just p) n a b) = outputG p ++ " subroutine "++(outputG n)++outputG a++"\n"++ - outputG b++ - "\nend subroutine "++(outputG n)++"\n" - outputF (Sub _ _ Nothing n a b) = "subroutine "++(outputG n)++outputG a++"\n"++ - outputG b++ - "\nend subroutine "++(outputG n)++"\n" - outputF (Function _ _ (Just p) n a (Just r) b) = outputG p ++ " function "++(outputG n)++outputG a++" result("++outputG r++")\n"++ - outputG b++ - "\nend function "++(outputG n)++"\n" - outputF (Function _ _ (Just p) n a Nothing b) = outputG p ++ " function "++(outputG n)++outputG a++"\n"++ - outputG b++ - "\nend function "++(outputG n)++"\n" - outputF (Function _ _ Nothing n a (Just r) b) = "function "++(outputG n)++outputG a++" result("++outputG r++")\n"++ - outputG b++ - "\nend function "++(outputG n)++"\n" - outputF (Function _ _ Nothing n a Nothing b) = "function "++(outputG n)++outputG a++"\n"++ - outputG b++ - "\nend function "++(outputG n)++"\n" - outputF (Main _ _ n a b []) = "program "++(outputG n) ++ - (if not (isEmptyArg a) then (outputG a) else ""++"\n") ++ - outputG b ++ - "\nend program "++ (outputG n) ++"\n" - outputF (Main _ _ n a b ps) = "program "++(outputG n) ++ - (if not (isEmptyArg a) then (outputG a) else ""++"\n") ++ - outputG b ++ + +instance (PPVersion v, PrintSlave a v) => PrintMaster [a] v where + printMaster xs = "[" ++ (concat $ intersperse ", " (map printSlave xs)) ++ "]" + +instance (PrintSlave (Arg p) v, + PrintSlave (BaseType p) v, + PrintSlave (Block p) v, + PrintSlave (Decl p) v, + PrintSlave (Fortran p) v, + PrintSlave (Implicit p) v, + PrintSlave (SubName p) v, + PrintSlave (VarName p) v, + PrintSlave (ProgUnit p) v, + PPVersion v) => PrintMaster (ProgUnit p) v where + printMaster (Sub _ _ (Just p) n a b) = printSlave p ++ " subroutine "++(printSlave n)++printSlave a++"\n"++ + printSlave b++ + "\nend subroutine "++(printSlave n)++"\n" + printMaster (Sub _ _ Nothing n a b) = "subroutine "++(printSlave n)++printSlave a++"\n"++ + printSlave b++ + "\nend subroutine "++(printSlave n)++"\n" + printMaster (Function _ _ (Just p) n a (Just r) b) = printSlave p ++ " function "++(printSlave n)++printSlave a++" result("++printSlave r++")\n"++ + printSlave b++ + "\nend function "++(printSlave n)++"\n" + printMaster (Function _ _ (Just p) n a Nothing b) = printSlave p ++ " function "++(printSlave n)++printSlave a++"\n"++ + printSlave b++ + "\nend function "++(printSlave n)++"\n" + printMaster (Function _ _ Nothing n a (Just r) b) = "function "++(printSlave n)++printSlave a++" result("++printSlave r++")\n"++ + printSlave b++ + "\nend function "++(printSlave n)++"\n" + printMaster (Function _ _ Nothing n a Nothing b) = "function "++(printSlave n)++printSlave a++"\n"++ + printSlave b++ + "\nend function "++(printSlave n)++"\n" + printMaster (Main _ _ n a b []) = "program "++(printSlave n) ++ + (if not (isEmptyArg a) then (printSlave a) else ""++"\n") ++ + printSlave b ++ + "\nend program "++ (printSlave n) ++"\n" + printMaster (Main _ _ n a b ps) = "program "++(printSlave n) ++ + (if not (isEmptyArg a) then (printSlave a) else ""++"\n") ++ + printSlave b ++ "\ncontains\n" ++ - (concatMap outputG ps) ++ - "\nend program "++(outputG n)++"\n" + (concatMap printSlave ps) ++ + "\nend program "++(printSlave n)++"\n" - outputF (Module _ _ n us i ds []) = "module "++(outputG n)++"\n" ++ + printMaster (Module _ _ n us i ds []) = "module "++(printSlave n)++"\n" ++ showUse us ++ - outputG i ++ - outputG ds ++ - "end module " ++ (outputG n)++"\n" - outputF (Module _ _ n us i ds ps) = "module "++(outputG n)++"\n" ++ + printSlave i ++ + printSlave ds ++ + "end module " ++ (printSlave n)++"\n" + printMaster (Module _ _ n us i ds ps) = "module "++(printSlave n)++"\n" ++ showUse us ++ - outputG i ++ - outputG ds ++ + printSlave i ++ + printSlave ds ++ "\ncontains\n" ++ - concatMap outputG ps ++ - "end module " ++ (outputG n)++"\n" - outputF (BlockData _ _ n us i ds) = "block data " ++ (outputG n) ++ "\n" ++ + concatMap printSlave ps ++ + "end module " ++ (printSlave n)++"\n" + printMaster (BlockData _ _ n us i ds) = "block data " ++ (printSlave n) ++ "\n" ++ showUse us ++ - outputG i ++ - outputG ds ++ - "end block data " ++ (outputG n)++"\n" - outputF (PSeq _ _ p p') = outputG p++outputG p' - outputF (Prog _ _ p) = outputG p - outputF (NullProg _ _) = "" - outputF (IncludeProg _ _ ds Nothing) = outputG ds - outputF (IncludeProg _ _ ds (Just f)) = outputG ds ++ "\n" ++ outputG f + printSlave i ++ + printSlave ds ++ + "end block data " ++ (printSlave n)++"\n" + printMaster (Prog _ _ p) = printSlave p + printMaster (NullProg _ _) = "" + printMaster (IncludeProg _ _ ds Nothing) = printSlave ds + printMaster (IncludeProg _ _ ds (Just f)) = printSlave ds ++ "\n" ++ printSlave f -instance (OutputG (Fortran p) v, OutputG (Decl p) v, OutputG (Implicit p) v, Alts v) => - OutputF (Block p) v where - outputF (Block _ (UseBlock us _) i sp ds f) = showUse us++outputG i++(outputG ds)++outputG f +instance (PrintSlave (Fortran p) v, PrintSlave (Decl p) v, PrintSlave (Implicit p) v, PPVersion v) => + PrintMaster (Block p) v where + printMaster (Block _ (UseBlock us _) i sp ds f) = showUse us++printSlave i++(printSlave ds)++printSlave f -instance (OutputG (Expr p) v) => OutputF (DataForm p) v where - outputF (Data _ ds) = "data "++(concat (intersperse "\n" (map show_data ds))) +instance (PrintSlave (Expr p) v) => PrintMaster (DataForm p) v where + printMaster (Data _ ds) = "data "++(concat (intersperse "\n" (map show_data ds))) instance (Indentor (Decl p), - OutputG (ArgList p) v, - OutputG (Attr p) v, - OutputG (BinOp p) v, - OutputG (Decl p) v, - OutputG (DataForm p) v, - OutputG (Expr p) v, - OutputG (GSpec p) v, - OutputG (InterfaceSpec p) v, - OutputG (MeasureUnitSpec p) v, - OutputG (SubName p) v, - OutputG (UnaryOp p) v, - OutputG (VarName p) v, - OutputG (Type p) v, - Alts v) => OutputF (Decl p) v where - outputF x@(Decl _ _ vs t) = (indR x 1)++outputG t++" :: "++asSeq id (map showDV vs)++"\n" - outputF (Namelist _ ns) = ind 1++"namelist "++show_namelist ns++"\n" - outputF (DataDecl _ ds) = ind 1++ (outputG ds) ++"\n" - outputF t@(Equivalence _ _ vs) = (indR t 1)++"equivlance ("++(concat (intersperse "," (map outputF vs))) ++ ")\n" - outputF (AttrStmt _ p gs) = ind 1++outputG p ++ " (" ++asSeq id (map showDV gs) ++ ") \n" - outputF (AccessStmt _ p []) = ind 1++outputG p ++ "\n" - outputF (AccessStmt _ p gs) = ind 1++outputG p ++ " :: " ++ (concat . intersperse ", " . map outputG) gs++"\n" - outputF (ExternalStmt _ xs) = ind 1++"external :: " ++ (concat (intersperse "," xs)) ++ "\n" - outputF (Interface _ (Just g) is) = ind 1 ++ "interface " ++ outputG g ++ outputG is ++ ind 1 ++ "end interface" ++ outputG g ++ "\n" - outputF (Common _ _ name exps) = ind 1++"common " ++ (case name of + PrintSlave (ArgList p) v, + PrintSlave (Attr p) v, + PrintSlave (BinOp p) v, + PrintSlave (Decl p) v, + PrintSlave (DataForm p) v, + PrintSlave (Expr p) v, + PrintSlave (GSpec p) v, + PrintSlave (InterfaceSpec p) v, + PrintSlave (MeasureUnitSpec p) v, + PrintSlave (SubName p) v, + PrintSlave (UnaryOp p) v, + PrintSlave (VarName p) v, + PrintSlave (Type p) v, + PPVersion v) => PrintMaster (Decl p) v where + printMaster x@(Decl _ _ vs t) = (indR x 1)++printSlave t++" :: "++asSeq id (map showDV vs)++"\n" + printMaster (Namelist _ ns) = ind 1++"namelist "++show_namelist ns++"\n" + printMaster (DataDecl _ ds) = ind 1++ (printSlave ds) ++"\n" + printMaster t@(Equivalence _ _ vs) = (indR t 1)++"equivlance ("++(concat (intersperse "," (map printMaster vs))) ++ ")\n" + printMaster (AttrStmt _ p gs) = ind 1++printSlave p ++ " (" ++asSeq id (map showDV gs) ++ ") \n" + printMaster (AccessStmt _ p []) = ind 1++printSlave p ++ "\n" + printMaster (AccessStmt _ p gs) = ind 1++printSlave p ++ " :: " ++ (concat . intersperse ", " . map printSlave) gs++"\n" + printMaster (ExternalStmt _ xs) = ind 1++"external :: " ++ (concat (intersperse "," xs)) ++ "\n" + printMaster (Interface _ (Just g) is) = ind 1 ++ "interface " ++ printSlave g ++ printSlave is ++ ind 1 ++ "end interface" ++ printSlave g ++ "\n" + printMaster (Common _ _ name exps) = ind 1++"common " ++ (case name of Just n -> "/" ++ n ++ "/ " - Nothing -> "") ++ (concat (intersperse "," (map outputF exps))) ++ "\n" - outputF (Interface _ Nothing is) = ind 1 ++ "interface " ++ outputG is ++ ind 1 ++ "end interface\n" - 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" - outputF (MeasureUnitDef _ _ ds) = ind 1 ++ "unit :: " ++ (concat . intersperse ", " . map showDU) ds ++ "\n" - outputF (Include _ i) = "include "++outputG i - outputF (DSeq _ d d') = outputG d++outputG d' - outputF (NullDecl _ _) = "" + Nothing -> "") ++ (concat (intersperse "," (map printMaster exps))) ++ "\n" + printMaster (Interface _ Nothing is) = ind 1 ++ "interface " ++ printSlave is ++ ind 1 ++ "end interface\n" + printMaster (DerivedTypeDef _ _ n as ps ds) = ind 1 ++ "type " ++ printMasterList as ++ " :: " ++ printSlave n ++ "\n" ++ (concat (intersperse "\n" (map (printSlave) ps))) ++ (if (length ps > 0) then "\n" else "") ++ (concatMap (((ind 2) ++) . printSlave) ds) ++ ind 1 ++ "end type " ++ printSlave n ++ "\n\n" + printMaster (MeasureUnitDef _ _ ds) = ind 1 ++ "unit :: " ++ (concat . intersperse ", " . map showDU) ds ++ "\n" + printMaster (Include _ i) = "include "++printSlave i + printMaster (DSeq _ d d') = printSlave d++printSlave d' + printMaster (NullDecl _ _) = "" -show_namelist ((x,xs):[]) = "/" ++ outputG x ++ "/" ++ (concat (intersperse ", " (map outputG xs))) -show_namelist ((x,xs):ys) = "/" ++ outputG x ++ "/" ++ (concat (intersperse ", " (map outputG xs))) ++ "," ++ show_namelist ys -show_data ((xs,ys)) = "/" ++ outputG xs ++ "/" ++ outputG ys +show_namelist ((x,xs):[]) = "/" ++ printSlave x ++ "/" ++ (concat (intersperse ", " (map printSlave xs))) +show_namelist ((x,xs):ys) = "/" ++ printSlave x ++ "/" ++ (concat (intersperse ", " (map printSlave xs))) ++ "," ++ show_namelist ys +show_data ((xs,ys)) = "/" ++ printSlave xs ++ "/" ++ printSlave ys -- showDV :: (Expr,Expr) -> String -showDV (v, NullExpr _ _, Just n) = (outputF v) ++ "*" ++ show n -showDV (v, NullExpr _ _, Nothing) = outputF v -showDV (v,e,Nothing) = outputF v++" = "++outputF e -showDV (v,e,Just n) = (outputF v) ++ "*" ++ show n ++ " = "++(outputF e) - -showDU (name,spec) = outputF name++" = "++outputF spec - -instance (OutputG (ArgList p) v, - OutputG (BinOp p) v, - OutputG (UnaryOp p) v, - OutputG (BaseType p) v, - OutputG (Expr p) v, - OutputG (MeasureUnitSpec p) v, - OutputG (VarName p) v, - Alts v) => OutputF (Type p) v where - outputF (BaseType _ bt as (NullExpr _ _) (NullExpr _ _)) = outputG bt++outputFList as - outputF (BaseType _ bt as (NullExpr _ _) e') = outputG bt++" (len="++outputG e'++")"++outputFList as - outputF (BaseType _ bt as e (NullExpr _ _)) = outputG bt++" (kind="++outputG e++")"++outputFList as - outputF (BaseType _ bt as e e') = outputG bt++" (len="++outputG e'++"kind="++outputG e++")"++outputFList as - outputF (ArrayT _ [] bt as (NullExpr _ _) (NullExpr _ _)) = outputG bt++outputFList as - outputF (ArrayT _ [] bt as (NullExpr _ _) e') = outputG bt++" (len="++outputG e'++")"++outputFList as - outputF (ArrayT _ [] bt as e (NullExpr _ _)) = outputG bt++" (kind="++outputG e++")"++outputFList as - outputF (ArrayT _ [] bt as e e') = outputG bt++" (len="++outputG e'++"kind="++outputG e++")"++outputFList as - outputF (ArrayT _ rs bt as (NullExpr _ _) (NullExpr _ _)) = outputG bt++" , dimension ("++showRanges rs++")"++outputFList as - outputF (ArrayT _ rs bt as (NullExpr _ _) e') = outputG bt++" (len="++outputG e'++")"++" , dimension ("++showRanges rs++")"++outputFList as - outputF (ArrayT _ rs bt as e (NullExpr _ _)) = outputG bt++" (kind="++outputG e++")"++" , dimension ("++showRanges rs++")"++outputFList as - outputF (ArrayT _ rs bt as e e') = outputG bt++" (len="++outputG e'++"kind="++outputG e++")"++" , dimension ("++showRanges rs++")"++outputFList as - - -instance (OutputG (ArgList p) v, OutputG (BinOp p) v, OutputG (Expr p) v, OutputG (UnaryOp p) v, - OutputG (VarName p) v, - OutputG (MeasureUnitSpec p) v, Alts v) => OutputF (Attr p) v where --new - outputF (Allocatable _) = "allocatable " - outputF (Parameter _) = "parameter " - outputF (External _) = "external " - outputF (Intent _ (In _)) = "intent(in) " - outputF (Intent _ (Out _)) = "intent(out) " - outputF (Intent _ (InOut _)) = "intent(inout) " - outputF (Intrinsic _) = "intrinsic " - outputF (Optional _) = "optional " - outputF (Pointer _) = "pointer " - outputF (Save _) = "save " - outputF (Target _) = "target " - outputF (Volatile _) = "volatile " - outputF (Public _) = "public " - outputF (Private _) = "private " - outputF (Sequence _) = "sequence " - outputF (Dimension _ r) = "dimension (" ++ (showRanges r) ++ ")" - outputF (MeasureUnit _ u) = "unit("++outputG u++")" - -instance (Alts v) => OutputF (MeasureUnitSpec p) v where - outputF (UnitProduct _ units) = showUnits units - outputF (UnitQuotient _ units1 units2) = showUnits units1++" / "++showUnits units2 - outputF (UnitNone _) = "" - -instance (Alts v) => OutputF (Fraction p) v where - outputF (IntegerConst _ s) = "**"++outputG s - outputF (FractionConst _ p q) = "**("++outputG p++"/"++outputG q++")" - outputF (NullFraction _) = "" - -instance (OutputG (Arg p) v, OutputG (BinOp p) v, OutputG (Expr p) v, Alts v) => OutputF (GSpec p) v where - outputF (GName _ s) = outputG s - outputF (GOper _ op) = "operator("++outputG op++")" - outputF (GAssg _) = "assignment(=)" - -instance (OutputG (Arg p) v, OutputG (Decl p) v, OutputG (Implicit p) v, - OutputG (SubName p) v, Alts v) => OutputF (InterfaceSpec p) v where - outputF (FunctionInterface _ s as us i ds) = (ind 1)++ "function " ++ outputG s ++ outputG as ++ showUse us ++ outputG i ++ outputG ds ++ "\nend function " ++ outputG s - outputF (SubroutineInterface _ s as us i ds) = (ind 1)++ "subroutine " ++ outputG s ++ outputG as ++ showUse us ++ outputG i ++ outputG ds ++ "\nend subroutine " ++ outputG s - outputF (ModuleProcedure _ ss) = (ind 2) ++ "module procedure " ++ concat (intersperse ", " (map (outputG) ss)) - -instance (Alts v, OutputF (Uses p) v) => OutputF (UseBlock p) v where - outputF (UseBlock uses _) = outputF uses - -instance (Alts v) => OutputF (Uses p) v where - outputF u = showUse u - -instance (OutputG (SubName p) v, Alts v) => OutputF (BaseType p) v where - outputF (Integer _) = "integer" - outputF (Real _) = "real" - outputF (DoublePrecision _) = "double precision" - outputF (Character _) = "character" - outputF (Logical _) = "logical" - outputF (DerivedType _ s) = "type ("++outputG s++")" - outputF (SomeType _) = error "sometype not valid in output source file" +showDV (v, NullExpr _ _, Just n) = (printMaster v) ++ "*" ++ show n +showDV (v, NullExpr _ _, Nothing) = printMaster v +showDV (v,e,Nothing) = printMaster v++" = "++printMaster e +showDV (v,e,Just n) = (printMaster v) ++ "*" ++ show n ++ " = "++(printMaster e) + +showDU (name,spec) = printMaster name++" = "++printMaster spec + +instance (PrintSlave (ArgList p) v, + PrintSlave (BinOp p) v, + PrintSlave (UnaryOp p) v, + PrintSlave (BaseType p) v, + PrintSlave (Expr p) v, + PrintSlave (MeasureUnitSpec p) v, + PrintSlave (VarName p) v, + PPVersion v) => PrintMaster (Type p) v where + printMaster (BaseType _ bt as (NullExpr _ _) (NullExpr _ _)) = printSlave bt++printMasterList as + printMaster (BaseType _ bt as (NullExpr _ _) e') = printSlave bt++" (len="++printSlave e'++")"++printMasterList as + printMaster (BaseType _ bt as e (NullExpr _ _)) = printSlave bt++" (kind="++printSlave e++")"++printMasterList as + printMaster (BaseType _ bt as e e') = printSlave bt++" (len="++printSlave e'++"kind="++printSlave e++")"++printMasterList as + printMaster (ArrayT _ [] bt as (NullExpr _ _) (NullExpr _ _)) = printSlave bt++printMasterList as + printMaster (ArrayT _ [] bt as (NullExpr _ _) e') = printSlave bt++" (len="++printSlave e'++")"++printMasterList as + printMaster (ArrayT _ [] bt as e (NullExpr _ _)) = printSlave bt++" (kind="++printSlave e++")"++printMasterList as + printMaster (ArrayT _ [] bt as e e') = printSlave bt++" (len="++printSlave e'++"kind="++printSlave e++")"++printMasterList as + printMaster (ArrayT _ rs bt as (NullExpr _ _) (NullExpr _ _)) = printSlave bt++" , dimension ("++showRanges rs++")"++printMasterList as + printMaster (ArrayT _ rs bt as (NullExpr _ _) e') = printSlave bt++" (len="++printSlave e'++")"++" , dimension ("++showRanges rs++")"++printMasterList as + printMaster (ArrayT _ rs bt as e (NullExpr _ _)) = printSlave bt++" (kind="++printSlave e++")"++" , dimension ("++showRanges rs++")"++printMasterList as + printMaster (ArrayT _ rs bt as e e') = printSlave bt++" (len="++printSlave e'++"kind="++printSlave e++")"++" , dimension ("++showRanges rs++")"++printMasterList as + + +instance (PrintSlave (ArgList p) v, PrintSlave (BinOp p) v, PrintSlave (Expr p) v, PrintSlave (UnaryOp p) v, + PrintSlave (VarName p) v, + PrintSlave (MeasureUnitSpec p) v, PPVersion v) => PrintMaster (Attr p) v where --new + printMaster (Allocatable _) = "allocatable " + printMaster (Parameter _) = "parameter " + printMaster (External _) = "external " + printMaster (Intent _ (In _)) = "intent(in) " + printMaster (Intent _ (Out _)) = "intent(out) " + printMaster (Intent _ (InOut _)) = "intent(inout) " + printMaster (Intrinsic _) = "intrinsic " + printMaster (Optional _) = "optional " + printMaster (Pointer _) = "pointer " + printMaster (Save _) = "save " + printMaster (Target _) = "target " + printMaster (Volatile _) = "volatile " + printMaster (Public _) = "public " + printMaster (Private _) = "private " + printMaster (Sequence _) = "sequence " + printMaster (Dimension _ r) = "dimension (" ++ (showRanges r) ++ ")" + printMaster (MeasureUnit _ u) = "unit("++printSlave u++")" + +instance (PPVersion v) => PrintMaster (MeasureUnitSpec p) v where + printMaster (UnitProduct _ units) = showUnits units + printMaster (UnitQuotient _ units1 units2) = showUnits units1++" / "++showUnits units2 + printMaster (UnitNone _) = "" + +instance (PPVersion v) => PrintMaster (Fraction p) v where + printMaster (IntegerConst _ s) = "**"++printSlave s + printMaster (FractionConst _ p q) = "**("++printSlave p++"/"++printSlave q++")" + printMaster (NullFraction _) = "" + +instance (PrintSlave (Arg p) v, PrintSlave (BinOp p) v, PrintSlave (Expr p) v, PPVersion v) => PrintMaster (GSpec p) v where + printMaster (GName _ s) = printSlave s + printMaster (GOper _ op) = "operator("++printSlave op++")" + printMaster (GAssg _) = "assignment(=)" + +instance (PrintSlave (Arg p) v, PrintSlave (Decl p) v, PrintSlave (Implicit p) v, + PrintSlave (SubName p) v, PPVersion v) => PrintMaster (InterfaceSpec p) v where + printMaster (FunctionInterface _ s as us i ds) = (ind 1)++ "function " ++ printSlave s ++ printSlave as ++ showUse us ++ printSlave i ++ printSlave ds ++ "\nend function " ++ printSlave s + printMaster (SubroutineInterface _ s as us i ds) = (ind 1)++ "subroutine " ++ printSlave s ++ printSlave as ++ showUse us ++ printSlave i ++ printSlave ds ++ "\nend subroutine " ++ printSlave s + printMaster (ModuleProcedure _ ss) = (ind 2) ++ "module procedure " ++ concat (intersperse ", " (map (printSlave) ss)) + +instance (PPVersion v, PrintMaster (Uses p) v) => PrintMaster (UseBlock p) v where + printMaster (UseBlock uses _) = printMaster uses + +instance (PPVersion v) => PrintMaster (Uses p) v where + printMaster u = showUse u + +instance (PrintSlave (SubName p) v, PPVersion v) => PrintMaster (BaseType p) v where + printMaster (Integer _) = "integer" + printMaster (Real _) = "real" + printMaster (DoublePrecision _) = "double precision" + printMaster (Character _) = "character" + printMaster (Logical _) = "logical" + printMaster (DerivedType _ s) = "type ("++printSlave s++")" + printMaster (SomeType _) = error "sometype not valid in output source file" -- Printing statements and expressions -- -instance (OutputG (ArgList p) v, - OutputG (BinOp p) v, - OutputG (Expr p) v, - OutputG (UnaryOp p) v, - OutputG (VarName p) v, - Alts v) => OutputF (Expr p) v where - outputF (Con _ _ i) = i - outputF (ConL _ _ m s) = m:("\'" ++ s ++ "\'") - outputF (ConS _ _ s) = s - outputF (Var _ _ vs) = showPartRefList vs - outputF (Bin _ _ bop e@(Bin _ _ op _ _ ) e'@(Bin _ _ op' _ _)) = checkPrec bop op (paren) (outputG e)++outputG bop++ checkPrec bop op' (paren) (outputG e') - outputF (Bin _ _ bop e@(Bin _ _ op _ _) e') = checkPrec bop op (paren) (outputG e)++outputG bop++outputG e' - outputF (Bin _ _ bop e e'@(Bin _ _ op' _ _)) = outputG e++outputG bop++checkPrec bop op' (paren) (outputG e') - outputF (Bin _ _ bop e e') = outputG e++outputG bop++outputG e' - outputF (Unary _ _ uop e) = "("++outputG uop++outputG e++")" - outputF (CallExpr _ _ s as) = outputG s ++ outputG as - outputF (Null _ _) = "NULL()" - outputF (NullExpr _ _) = "" - outputF (ESeq _ _ (NullExpr _ _) e) = outputG e - outputF (ESeq _ _ e (NullExpr _ _)) = outputG e - outputF (ESeq _ _ e e') = outputG e++","++outputG e' - outputF (Bound _ _ e e') = outputG e++":"++outputG e' - outputF (Sqrt _ _ e) = "sqrt("++outputG e++")" - outputF (ArrayCon _ _ es) = "(\\" ++ concat (intersperse ", " (map (outputG) es)) ++ "\\)" - outputF (AssgExpr _ _ v e) = v ++ "=" ++ outputG e - -instance (OutputIndF (Fortran p) v, Alts v) => OutputF (Fortran p) v where - outputF = outputIndF 1 - -instance (OutputG (ArgName p) v, Alts v) => OutputF (Arg p) v where - outputF (Arg _ vs _) = "("++ outputG vs ++")" +instance (PrintSlave (ArgList p) v, + PrintSlave (BinOp p) v, + PrintSlave (Expr p) v, + PrintSlave (UnaryOp p) v, + PrintSlave (VarName p) v, + PPVersion v) => PrintMaster (Expr p) v where + printMaster (Con _ _ i) = i + printMaster (ConL _ _ m s) = m:("\'" ++ s ++ "\'") + printMaster (ConS _ _ s) = s + printMaster (Var _ _ vs) = showPartRefList vs + printMaster (Bin _ _ bop e@(Bin _ _ op _ _ ) e'@(Bin _ _ op' _ _)) = checkPrec bop op (paren) (printSlave e)++printSlave bop++ checkPrec bop op' (paren) (printSlave e') + printMaster (Bin _ _ bop e@(Bin _ _ op _ _) e') = checkPrec bop op (paren) (printSlave e)++printSlave bop++printSlave e' + printMaster (Bin _ _ bop e e'@(Bin _ _ op' _ _)) = printSlave e++printSlave bop++checkPrec bop op' (paren) (printSlave e') + printMaster (Bin _ _ bop e e') = printSlave e++printSlave bop++printSlave e' + printMaster (Unary _ _ uop e) = "("++printSlave uop++printSlave e++")" + printMaster (CallExpr _ _ s as) = printSlave s ++ printSlave as + printMaster (Null _ _) = "NULL()" + printMaster (NullExpr _ _) = "" + printMaster (ESeq _ _ (NullExpr _ _) e) = printSlave e + printMaster (ESeq _ _ e (NullExpr _ _)) = printSlave e + printMaster (ESeq _ _ e e') = printSlave e++","++printSlave e' + printMaster (Bound _ _ e e') = printSlave e++":"++printSlave e' + printMaster (Sqrt _ _ e) = "sqrt("++printSlave e++")" + printMaster (ArrayCon _ _ es) = "(\\" ++ concat (intersperse ", " (map (printSlave) es)) ++ "\\)" + printMaster (AssgExpr _ _ v e) = v ++ "=" ++ printSlave e + +instance (PrintIndMaster (Fortran p) v, PPVersion v) => PrintMaster (Fortran p) v where + printMaster = printIndMaster 1 + +instance (PrintSlave (ArgName p) v, PPVersion v) => PrintMaster (Arg p) v where + printMaster (Arg _ vs _) = "("++ printSlave vs ++")" -instance (OutputG (Expr p) v, Alts v) => OutputF (ArgList p) v where - outputF (ArgList _ es) = "("++outputG es++")" -- asTuple outputG es +instance (PrintSlave (Expr p) v, PPVersion v) => PrintMaster (ArgList p) v where + printMaster (ArgList _ es) = "("++printSlave es++")" -- asTuple printSlave es -instance Alts v => OutputF (BinOp p) v where - outputF (Plus _) ="+" - outputF (Minus _) ="-" - outputF (Mul _) ="*" - outputF (Div _) ="/" - outputF (Or _) =".or." - outputF (And _) =".and." - outputF (Concat _) ="//" - outputF (Power _) ="**" - outputF (RelEQ _) ="==" - outputF (RelNE _) ="/=" - outputF (RelLT _) ="<" - outputF (RelLE _) ="<=" - outputF (RelGT _) =">" - outputF (RelGE _) =">=" - -instance Alts v => OutputF (UnaryOp p) v where - outputF (UMinus _) = "-" - outputF (Not _) = ".not." +instance PPVersion v => PrintMaster (BinOp p) v where + printMaster (Plus _) ="+" + printMaster (Minus _) ="-" + printMaster (Mul _) ="*" + printMaster (Div _) ="/" + printMaster (Or _) =".or." + printMaster (And _) =".and." + printMaster (Concat _) ="//" + printMaster (Power _) ="**" + printMaster (RelEQ _) ="==" + printMaster (RelNE _) ="/=" + printMaster (RelLT _) ="<" + printMaster (RelLE _) ="<=" + printMaster (RelGT _) =">" + printMaster (RelGE _) =">=" + +instance PPVersion v => PrintMaster (UnaryOp p) v where + printMaster (UMinus _) = "-" + printMaster (Not _) = ".not." -instance Alts v => OutputF (VarName p) v where - outputF (VarName _ v) = v - -instance (OutputG (VarName p) v, OutputG (ArgName p) v, Alts v) => OutputF (ArgName p) v where - outputF (ArgName _ a) = a - outputF (ASeq _ (NullArg _) (NullArg _)) = "" - outputF (ASeq _ (NullArg _) a') = outputG a' - outputF (ASeq _ a (NullArg _)) = outputG a - outputF (ASeq _ a a') = outputG a++","++outputG a' - outputF (NullArg _) = "" - -instance Alts v => OutputF (SubName p) v where - outputF (SubName _ n) = n - outputF (NullSubName _) = error "subroutine needs a name" - -instance Alts v => OutputF ( Implicit p) v where - outputF (ImplicitNone _) = " implicit none\n" - outputF (ImplicitNull _) = "" +instance PPVersion v => PrintMaster (VarName p) v where + printMaster (VarName _ v) = v + +instance (PrintSlave (VarName p) v, PrintSlave (ArgName p) v, PPVersion v) => PrintMaster (ArgName p) v where + printMaster (ArgName _ a) = a + printMaster (ASeq _ (NullArg _) (NullArg _)) = "" + printMaster (ASeq _ (NullArg _) a') = printSlave a' + printMaster (ASeq _ a (NullArg _)) = printSlave a + printMaster (ASeq _ a a') = printSlave a++","++printSlave a' + printMaster (NullArg _) = "" + +instance PPVersion v => PrintMaster (SubName p) v where + printMaster (SubName _ n) = n + printMaster (NullSubName _) = error "subroutine needs a name" + +instance PPVersion v => PrintMaster ( Implicit p) v where + printMaster (ImplicitNone _) = " implicit none\n" + printMaster (ImplicitNull _) = "" -instance (OutputG (Expr p) v, Alts v) => OutputF (Spec p) v where - outputF (Access _ s) = "access = " ++ outputG s - outputF (Action _ s) = "action = "++outputG s - outputF (Advance _ s) = "advance = "++outputG s - outputF (Blank _ s) = "blank = "++outputG s - outputF (Delim _ s) = "delim = "++outputG s - outputF (Direct _ s) = "direct = "++outputG s - outputF (End _ s) = "end = "++outputG s - outputF (Eor _ s) = "eor = "++outputG s - outputF (Err _ s) = "err = "++outputG s - outputF (Exist _ s) = "exist = "++outputG s - outputF (File _ s) = "file = "++outputG s - outputF (FMT _ s) = "fmt = "++outputG s - outputF (Form _ s) = "form = "++outputG s - outputF (Formatted _ s) = "formatted = "++outputG s - outputF (Unformatted _ s) = "unformatted = "++outputG s - outputF (IOLength _ s) = "iolength = "++outputG s - outputF (IOStat _ s) = "iostat = "++outputG s - outputF (Opened _ s) = "opened = "++outputG s - outputF (Name _ s) = "name = "++outputG s - outputF (Named _ s) = "named = "++outputG s - outputF (NextRec _ s) = "nextrec = "++outputG s - outputF (NML _ s) = "nml = "++outputG s - outputF (NoSpec _ s) = outputG s - outputF (Floating _ s1 s2) = outputG s1 ++ "F" ++ outputG s2 - outputF (Number _ s) = "number = "++outputG s - outputF (Pad _ s) = "pad = "++outputG s - outputF (Position _ s) = "position = "++outputG s - outputF (Read _ s) = "read = "++outputG s - outputF (ReadWrite _ s) = "readwrite = "++outputG s - outputF (WriteSp _ s) = "write = "++outputG s - outputF (Rec _ s) = "rec = "++outputG s - outputF (Recl _ s) = "recl = "++outputG s - outputF (Sequential _ s) = "sequential = "++outputG s - outputF (Size _ s) = "size = "++outputG s - outputF (Status _ s) = "status = "++outputG s - outputF (StringLit _ s) = "'" ++ s ++ "'" - outputF (Unit _ s) = "unit = "++outputG s - outputF (Delimiter _) = "/" +instance (PrintSlave (Expr p) v, PPVersion v) => PrintMaster (Spec p) v where + printMaster (Access _ s) = "access = " ++ printSlave s + printMaster (Action _ s) = "action = "++printSlave s + printMaster (Advance _ s) = "advance = "++printSlave s + printMaster (Blank _ s) = "blank = "++printSlave s + printMaster (Delim _ s) = "delim = "++printSlave s + printMaster (Direct _ s) = "direct = "++printSlave s + printMaster (End _ s) = "end = "++printSlave s + printMaster (Eor _ s) = "eor = "++printSlave s + printMaster (Err _ s) = "err = "++printSlave s + printMaster (Exist _ s) = "exist = "++printSlave s + printMaster (File _ s) = "file = "++printSlave s + printMaster (FMT _ s) = "fmt = "++printSlave s + printMaster (Form _ s) = "form = "++printSlave s + printMaster (Formatted _ s) = "formatted = "++printSlave s + printMaster (Unformatted _ s) = "unformatted = "++printSlave s + printMaster (IOLength _ s) = "iolength = "++printSlave s + printMaster (IOStat _ s) = "iostat = "++printSlave s + printMaster (Opened _ s) = "opened = "++printSlave s + printMaster (Name _ s) = "name = "++printSlave s + printMaster (Named _ s) = "named = "++printSlave s + printMaster (NextRec _ s) = "nextrec = "++printSlave s + printMaster (NML _ s) = "nml = "++printSlave s + printMaster (NoSpec _ s) = printSlave s + printMaster (Floating _ s1 s2) = printSlave s1 ++ "F" ++ printSlave s2 + printMaster (Number _ s) = "number = "++printSlave s + printMaster (Pad _ s) = "pad = "++printSlave s + printMaster (Position _ s) = "position = "++printSlave s + printMaster (Read _ s) = "read = "++printSlave s + printMaster (ReadWrite _ s) = "readwrite = "++printSlave s + printMaster (WriteSp _ s) = "write = "++printSlave s + printMaster (Rec _ s) = "rec = "++printSlave s + printMaster (Recl _ s) = "recl = "++printSlave s + printMaster (Sequential _ s) = "sequential = "++printSlave s + printMaster (Size _ s) = "size = "++printSlave s + printMaster (Status _ s) = "status = "++printSlave s + printMaster (StringLit _ s) = "'" ++ s ++ "'" + printMaster (Unit _ s) = "unit = "++printSlave s + printMaster (Delimiter _) = "/" + + + +showElseIf i (e,f) = (ind i)++"else if ("++printSlave e++") then\n"++(ind (i+1))++printSlave f++"\n" +showForall [] = "error" +showForall ((s,e,e',NullExpr _ _):[]) = s++"="++printSlave e++":"++printSlave e' +showForall ((s,e,e',e''):[]) = s++"="++printSlave e++":"++printSlave e'++"; "++printSlave e'' +showForall ((s,e,e',NullExpr _ _):is) = s++"="++printSlave e++":"++printSlave e'++", "++showForall is +showForall ((s,e,e',e''):is) = s++"="++printSlave e++":"++printSlave e'++"; "++printSlave e''++", "++showForall is +showUse :: Uses p -> String +showUse (UseNil _) = "" +showUse (Use _ (n, []) us _) = ((ind 1)++"use "++n++"\n") ++ (showUse us) +showUse (Use _ (n, renames) us _) = ((ind 1)++"use "++n++", " ++ + (concat $ intersperse ", " (map (\(a, b) -> a ++ " => " ++ b) renames)) ++ + "\n") ++ (showUse us) isEmptyArg (Arg _ as _) = and (isEmptyArgName as) @@ -450,81 +427,79 @@ opPrec (Power _) = 6 class Indentor t where indR :: t -> Int -> String - -- Default indenting for code straight out of the parser instance Indentor (p ()) where indR t i = ind i - instance (Indentor (Fortran p), - OutputG (VarName p) v, - OutputG (Expr p) v, - OutputG (UnaryOp p) v, - OutputG (BinOp p) v, - OutputG (ArgList p) v, - OutputIndG (Fortran p) v, - OutputG (DataForm p) v, - OutputG (Fortran p) v, OutputG (Spec p) v, Alts v) => OutputIndF (Fortran p) v where - - outputIndF i t@(Assg _ _ v e) = (indR t i)++outputG v++" = "++outputG e - outputIndF i t@(DoWhile _ _ e f) = (indR t i)++"do while (" ++ outputG e ++ ")\n" ++ - outputIndG (i+1) f ++ "\n" ++ (indR t i) ++ "end do" - outputIndF i t@(For _ _ (VarName _ "") e e' e'' f) = (indR t i)++"do \n"++ - (outputIndG (i+1) f)++"\n"++(indR t i)++"end do" - outputIndF i t@(For _ _ v e e' e'' f) = (indR t i)++"do"++" "++outputG v++" = "++outputG e++", "++ - outputG e'++", "++outputG e''++"\n"++ - (outputIndG (i+1) f)++"\n"++(indR t i)++"end do" - outputIndF i t@(FSeq _ _ f f') = outputIndG i f++"\n"++outputIndG i f' - outputIndF i t@(If _ _ e f [] Nothing) = (indR t i)++"if ("++outputG e++") then\n" - ++(outputIndG (i+1) f)++"\n" + PrintSlave (VarName p) v, + PrintSlave (Expr p) v, + PrintSlave (UnaryOp p) v, + PrintSlave (BinOp p) v, + PrintSlave (ArgList p) v, + PrintIndSlave (Fortran p) v, + PrintSlave (DataForm p) v, + PrintSlave (Fortran p) v, PrintSlave (Spec p) v, PPVersion v) => PrintIndMaster (Fortran p) v where + + printIndMaster i t@(Assg _ _ v e) = (indR t i)++printSlave v++" = "++printSlave e + printIndMaster i t@(DoWhile _ _ e f) = (indR t i)++"do while (" ++ printSlave e ++ ")\n" ++ + printIndSlave (i+1) f ++ "\n" ++ (indR t i) ++ "end do" + printIndMaster i t@(For _ _ (VarName _ "") e e' e'' f) = (indR t i)++"do \n"++ + (printIndSlave (i+1) f)++"\n"++(indR t i)++"end do" + printIndMaster i t@(For _ _ v e e' e'' f) = (indR t i)++"do"++" "++printSlave v++" = "++printSlave e++", "++ + printSlave e'++", "++printSlave e''++"\n"++ + (printIndSlave (i+1) f)++"\n"++(indR t i)++"end do" + printIndMaster i t@(FSeq _ _ f f') = printIndSlave i f++"\n"++printIndSlave i f' + printIndMaster i t@(If _ _ e f [] Nothing) = (indR t i)++"if ("++printSlave e++") then\n" + ++(printIndSlave (i+1) f)++"\n" ++(indR t i)++"end if" - outputIndF i t@(If _ _ e f [] (Just f')) = (indR t i)++"if ("++outputG e++") then\n" - ++(outputIndG (i+1) f)++"\n" + printIndMaster i t@(If _ _ e f [] (Just f')) = (indR t i)++"if ("++printSlave e++") then\n" + ++(printIndSlave (i+1) f)++"\n" ++(indR t i)++"else\n" - ++(outputIndG (i+1) f')++"\n" + ++(printIndSlave (i+1) f')++"\n" ++(indR t i)++"end if" - outputIndF i t@(If _ _ e f elsif Nothing) = (indR t i)++"if ("++outputG e++") then\n" - ++(outputIndG (i+1) f)++"\n" + printIndMaster i t@(If _ _ e f elsif Nothing) = (indR t i)++"if ("++printSlave e++") then\n" + ++(printIndSlave (i+1) f)++"\n" ++concat (map (showElseIf i) elsif) ++(indR t i)++"end if" - outputIndF i t@(If _ _ e f elsif (Just f')) = (indR t i)++"if ("++outputG e++") then\n" - ++(outputIndG (i+1) f)++"\n" + printIndMaster i t@(If _ _ e f elsif (Just f')) = (indR t i)++"if ("++printSlave e++") then\n" + ++(printIndSlave (i+1) f)++"\n" ++concat (map (showElseIf i) elsif) ++(indR t i)++"else\n" - ++(outputIndG (i+1) f')++"\n" + ++(printIndSlave (i+1) f')++"\n" ++(indR t i)++"end if" - outputIndF i t@(Allocate _ _ a (NullExpr _ _)) = (indR t i)++"allocate (" ++ outputG a ++ ")" - outputIndF i t@(Allocate _ _ a s) = (indR t i)++"allocate ("++ outputG a ++ ", STAT = "++outputG s++ ")" - outputIndF i t@(Backspace _ _ ss) = (indR t i)++"backspace "++asTuple outputG ss++"\n" - outputIndF i t@(Call _ _ sub al) = indR t i++"call "++outputG sub++outputG al - outputIndF i t@(Open _ _ s) = (indR t i)++"open "++asTuple outputG s++"\n" - - outputIndF i t@(Close _ _ ss) = (indR t i)++"close "++asTuple outputG ss++"\n" - outputIndF i t@(Continue _ _) = (indR t i)++"continue"++"\n" - outputIndF i t@(Cycle _ _ s) = (indR t i)++"cycle "++outputG s++"\n" - outputIndF i t@(DataStmt _ _ d) = (indR t i)++(outputG d)++"\n" - outputIndF i t@(Deallocate _ _ es e) = (indR t i)++"deallocate "++asTuple outputG es++outputG e++"\n" - outputIndF i t@(Endfile _ _ ss) = (indR t i)++"endfile "++asTuple outputG ss++"\n" - outputIndF i t@(Exit _ _ s) = (indR t i)++"exit "++outputG s - outputIndF i t@(Format _ _ es) = (indR t i)++"format " ++ (asTuple outputG es) - outputIndF i t@(Forall _ _ (is, (NullExpr _ _)) f) = (indR t i)++"forall ("++showForall is++") "++outputG f - outputIndF i t@(Forall _ _ (is,e) f) = (indR t i)++"forall ("++showForall is++","++outputG e++") "++outputG f - outputIndF i t@(Goto _ _ s) = (indR t i)++"goto "++outputG s - outputIndF i t@(Nullify _ _ es) = (indR t i)++"nullify "++asTuple outputG es++"\n" - outputIndF i t@(Inquire _ _ ss es) = (indR t i)++"inquire "++asTuple outputG ss++" "++(concat (intersperse "," (map outputG es)))++"\n" - outputIndF i t@(Pause _ _ s) = (indR t i)++"pause "++ show s ++ "\n" - outputIndF i t@(Rewind _ _ ss) = (indR t i)++"rewind "++asTuple outputG ss++"\n" - outputIndF i t@(Stop _ _ e) = (indR t i)++"stop "++outputG e++"\n" - outputIndF i t@(Where _ _ e f Nothing) = (indR t i)++"where ("++outputG e++") "++outputG f - 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" - outputIndF i t@(Write _ _ ss es) = (indR t i)++"write "++asTuple outputG ss++" "++(concat (intersperse "," (map outputG es)))++"\n" - outputIndF i t@(PointerAssg _ _ e e') = (indR t i)++outputG e++" => "++outputG e'++"\n" - outputIndF i t@(Return _ _ e) = (indR t i)++"return "++outputG e++"\n" - outputIndF i t@(Label _ _ s f) = s++" "++outputG f - outputIndF i t@(Print _ _ e []) = (indR t i)++("print ")++outputG e++("\n") - outputIndF i t@(Print _ _ e es) = (indR t i)++("print ")++outputG e++", "++(concat (intersperse "," (map outputG es)))++("\n") - outputIndF i t@(ReadS _ _ ss es) = (indR t i)++("read ")++(asTuple outputG ss)++" "++(concat (intersperse "," (map outputG es)))++("\n") - outputIndF i t@(NullStmt _ _) = "" + printIndMaster i t@(Allocate _ _ a (NullExpr _ _)) = (indR t i)++"allocate (" ++ printSlave a ++ ")" + printIndMaster i t@(Allocate _ _ a s) = (indR t i)++"allocate ("++ printSlave a ++ ", STAT = "++printSlave s++ ")" + printIndMaster i t@(Backspace _ _ ss) = (indR t i)++"backspace "++asTuple printSlave ss++"\n" + printIndMaster i t@(Call _ _ sub al) = indR t i++"call "++printSlave sub++printSlave al + printIndMaster i t@(Open _ _ s) = (indR t i)++"open "++asTuple printSlave s++"\n" + + printIndMaster i t@(Close _ _ ss) = (indR t i)++"close "++asTuple printSlave ss++"\n" + printIndMaster i t@(Continue _ _) = (indR t i)++"continue"++"\n" + printIndMaster i t@(Cycle _ _ s) = (indR t i)++"cycle "++printSlave s++"\n" + printIndMaster i t@(DataStmt _ _ d) = (indR t i)++(printSlave d)++"\n" + printIndMaster i t@(Deallocate _ _ es e) = (indR t i)++"deallocate "++asTuple printSlave es++printSlave e++"\n" + printIndMaster i t@(Endfile _ _ ss) = (indR t i)++"endfile "++asTuple printSlave ss++"\n" + printIndMaster i t@(Exit _ _ s) = (indR t i)++"exit "++printSlave s + printIndMaster i t@(Format _ _ es) = (indR t i)++"format " ++ (asTuple printSlave es) + printIndMaster i t@(Forall _ _ (is, (NullExpr _ _)) f) = (indR t i)++"forall ("++showForall is++") "++printSlave f + printIndMaster i t@(Forall _ _ (is,e) f) = (indR t i)++"forall ("++showForall is++","++printSlave e++") "++printSlave f + printIndMaster i t@(Goto _ _ s) = (indR t i)++"goto "++printSlave s + printIndMaster i t@(Nullify _ _ es) = (indR t i)++"nullify "++asTuple printSlave es++"\n" + printIndMaster i t@(Inquire _ _ ss es) = (indR t i)++"inquire "++asTuple printSlave ss++" "++(concat (intersperse "," (map printSlave es)))++"\n" + printIndMaster i t@(Pause _ _ s) = (indR t i)++"pause "++ show s ++ "\n" + printIndMaster i t@(Rewind _ _ ss) = (indR t i)++"rewind "++asTuple printSlave ss++"\n" + printIndMaster i t@(Stop _ _ e) = (indR t i)++"stop "++printSlave e++"\n" + printIndMaster i t@(Where _ _ e f Nothing) = (indR t i)++"where ("++printSlave e++") "++printSlave f + printIndMaster i t@(Where _ _ e f (Just f')) = (indR t i)++"where ("++printSlave e++") "++(printIndSlave (i + 1) f)++"\n"++(indR t i)++"elsewhere\n" ++ (indR t i) ++ (printIndSlave (i + 1) f') ++ "\n" ++ (indR t i) ++ "end where" + printIndMaster i t@(Write _ _ ss es) = (indR t i)++"write "++asTuple printSlave ss++" "++(concat (intersperse "," (map printSlave es)))++"\n" + printIndMaster i t@(PointerAssg _ _ e e') = (indR t i)++printSlave e++" => "++printSlave e'++"\n" + printIndMaster i t@(Return _ _ e) = (indR t i)++"return "++printSlave e++"\n" + printIndMaster i t@(Label _ _ s f) = s++" "++printSlave f + printIndMaster i t@(Print _ _ e []) = (indR t i)++("print ")++printSlave e++("\n") + printIndMaster i t@(Print _ _ e es) = (indR t i)++("print ")++printSlave e++", "++(concat (intersperse "," (map printSlave es)))++("\n") + printIndMaster i t@(ReadS _ _ ss es) = (indR t i)++("read ")++(asTuple printSlave ss)++" "++(concat (intersperse "," (map printSlave es)))++("\n") + printIndMaster i t@(NullStmt _ _) = "" -- infix 7 $+ -- infix 7 $- @@ -559,34 +534,34 @@ asParagraphs = printList ["\n","\n\n","\n"] -- Auxiliary functions -- -optTuple :: (?variant :: v, Alts v, OutputG (UnaryOp p) v, OutputF (Expr p) v) => [Expr p] -> String +optTuple :: (?variant :: v, PPVersion v, PrintSlave (UnaryOp p) v, PrintMaster (Expr p) v) => [Expr p] -> String optTuple [] = "" -optTuple xs = asTuple outputF xs +optTuple xs = asTuple printMaster xs -- *optTuple xs = "" -- indent and showInd enable indented printing -- -showUnits :: (Alts v, ?variant :: v, OutputF (Fraction p) v) => [(MeasureUnit, Fraction p)] -> String +showUnits :: (PPVersion v, ?variant :: v, PrintMaster (Fraction p) v) => [(MeasureUnit, Fraction p)] -> String showUnits units | null units = "1" - | otherwise = printList [""," ",""] (\(unit, f) -> unit++outputF f) units + | otherwise = printList [""," ",""] (\(unit, f) -> unit++printMaster f) units -outputFList :: (Alts v, ?variant :: v, OutputF a v) => [a] -> String -outputFList = concat . map (", "++) . map (outputF) +printMasterList :: (PPVersion v, ?variant :: v, PrintMaster a v) => [a] -> String +printMasterList = concat . map (", "++) . map (printMaster) -showBounds :: (Alts v, ?variant :: v, OutputF (Expr p) v) => (Expr p,Expr p) -> String +showBounds :: (PPVersion v, ?variant :: v, PrintMaster (Expr p) v) => (Expr p,Expr p) -> String showBounds (NullExpr _ _, NullExpr _ _) = ":" -showBounds (NullExpr _ _, e) = outputF e -showBounds (e1,e2) = outputF e1++":"++outputF e2 +showBounds (NullExpr _ _, e) = printMaster e +showBounds (e1,e2) = printMaster e1++":"++printMaster e2 -showRanges :: (Alts v, ?variant :: v, OutputF (Expr p) v) => [(Expr p, Expr p)] -> String +showRanges :: (PPVersion v, ?variant :: v, PrintMaster (Expr p) v) => [(Expr p, Expr p)] -> String showRanges = asSeq showBounds -showPartRefList :: (Alts v, ?variant :: v, OutputG (VarName p) v, - OutputG (UnaryOp p) v, OutputF (Expr p) v) => [(VarName p,[Expr p])] -> String +showPartRefList :: (PPVersion v, ?variant :: v, PrintSlave (VarName p) v, + PrintSlave (UnaryOp p) v, PrintMaster (Expr p) v) => [(VarName p,[Expr p])] -> String showPartRefList [] = "" -showPartRefList ((v,es):[]) = outputG v ++ optTuple es -showPartRefList ((v,es):xs) = outputG v ++ optTuple es ++ "%" ++ showPartRefList xs +showPartRefList ((v,es):[]) = printSlave v ++ optTuple es +showPartRefList ((v,es):xs) = printSlave v ++ optTuple es ++ "%" ++ showPartRefList xs From 2af45a8f9e638d76cb9ec9264f02c9de2493bbab Mon Sep 17 00:00:00 2001 From: Dominic Date: Mon, 27 Jul 2015 18:31:16 +0100 Subject: [PATCH 08/20] removed default list behaviours for master/slave, added specific one for interfacespecs which were previously wrong --- src/Language/Fortran/Pretty.hs | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/src/Language/Fortran/Pretty.hs b/src/Language/Fortran/Pretty.hs index d400368..64ecb75 100644 --- a/src/Language/Fortran/Pretty.hs +++ b/src/Language/Fortran/Pretty.hs @@ -55,18 +55,12 @@ instance PPVersion v => PrintSlave Char v where instance PPVersion v => PrintSlave String v where printSlave = id -instance (PPVersion v, PrintSlave a v, PrintSlave b v) => PrintSlave (a, b) v where - printSlave (a, b) = "(" ++ printSlave a ++ ", " ++ printSlave b ++ ")" - -instance (PPVersion v, PrintSlave a v) => PrintSlave [a] v where - printSlave xs = "[" ++ (concat $ intersperse ", " (map printSlave xs)) ++ "]" - -------------------------------------------------------------------------- -- Printing declarations instance (PPVersion v, PrintSlave a v) => PrintMaster [a] v where - printMaster xs = "[" ++ (concat $ intersperse ", " (map printSlave xs)) ++ "]" + printMaster xs = concat $ intersperse "\n" (map printSlave xs) instance (PrintSlave (Arg p) v, PrintSlave (BaseType p) v, @@ -145,7 +139,7 @@ instance (Indentor (Decl p), PrintSlave (DataForm p) v, PrintSlave (Expr p) v, PrintSlave (GSpec p) v, - PrintSlave (InterfaceSpec p) v, + PrintSlave [InterfaceSpec p] v, PrintSlave (MeasureUnitSpec p) v, PrintSlave (SubName p) v, PrintSlave (UnaryOp p) v, @@ -242,6 +236,9 @@ instance (PrintSlave (Arg p) v, PrintSlave (BinOp p) v, PrintSlave (Expr p) v, P printMaster (GOper _ op) = "operator("++printSlave op++")" printMaster (GAssg _) = "assignment(=)" +instance (PrintMaster (InterfaceSpec p) v) => PrintMaster [InterfaceSpec p] v where + printMaster xs = concat $ intersperse "\n" (map printMaster xs) + instance (PrintSlave (Arg p) v, PrintSlave (Decl p) v, PrintSlave (Implicit p) v, PrintSlave (SubName p) v, PPVersion v) => PrintMaster (InterfaceSpec p) v where printMaster (FunctionInterface _ s as us i ds) = (ind 1)++ "function " ++ printSlave s ++ printSlave as ++ showUse us ++ printSlave i ++ printSlave ds ++ "\nend function " ++ printSlave s From 10f6087cb0464e796f611cd0e01405e97c00fdbe Mon Sep 17 00:00:00 2001 From: Dominic Date: Mon, 27 Jul 2015 18:38:32 +0100 Subject: [PATCH 09/20] [InterfaceSpec] instance removed --- src/Language/Fortran/Pretty.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Language/Fortran/Pretty.hs b/src/Language/Fortran/Pretty.hs index 64ecb75..1830a30 100644 --- a/src/Language/Fortran/Pretty.hs +++ b/src/Language/Fortran/Pretty.hs @@ -132,6 +132,7 @@ instance (PrintSlave (Expr p) v) => PrintMaster (DataForm p) v where printMaster (Data _ ds) = "data "++(concat (intersperse "\n" (map show_data ds))) instance (Indentor (Decl p), + PrintSlave (Arg p) v, PrintSlave (ArgList p) v, PrintSlave (Attr p) v, PrintSlave (BinOp p) v, @@ -139,7 +140,8 @@ instance (Indentor (Decl p), PrintSlave (DataForm p) v, PrintSlave (Expr p) v, PrintSlave (GSpec p) v, - PrintSlave [InterfaceSpec p] v, + PrintSlave (Implicit p) v, + PrintSlave (InterfaceSpec p) v, PrintSlave (MeasureUnitSpec p) v, PrintSlave (SubName p) v, PrintSlave (UnaryOp p) v, @@ -154,17 +156,19 @@ instance (Indentor (Decl p), printMaster (AccessStmt _ p []) = ind 1++printSlave p ++ "\n" printMaster (AccessStmt _ p gs) = ind 1++printSlave p ++ " :: " ++ (concat . intersperse ", " . map printSlave) gs++"\n" printMaster (ExternalStmt _ xs) = ind 1++"external :: " ++ (concat (intersperse "," xs)) ++ "\n" - printMaster (Interface _ (Just g) is) = ind 1 ++ "interface " ++ printSlave g ++ printSlave is ++ ind 1 ++ "end interface" ++ printSlave g ++ "\n" + printMaster (Interface _ (Just g) is) = ind 1 ++ "interface " ++ printSlave g ++ printMasterInterfaceSpecs is ++ ind 1 ++ "end interface" ++ printSlave g ++ "\n" printMaster (Common _ _ name exps) = ind 1++"common " ++ (case name of Just n -> "/" ++ n ++ "/ " Nothing -> "") ++ (concat (intersperse "," (map printMaster exps))) ++ "\n" - printMaster (Interface _ Nothing is) = ind 1 ++ "interface " ++ printSlave is ++ ind 1 ++ "end interface\n" + printMaster (Interface _ Nothing is) = ind 1 ++ "interface " ++ printMasterInterfaceSpecs is ++ ind 1 ++ "end interface\n" printMaster (DerivedTypeDef _ _ n as ps ds) = ind 1 ++ "type " ++ printMasterList as ++ " :: " ++ printSlave n ++ "\n" ++ (concat (intersperse "\n" (map (printSlave) ps))) ++ (if (length ps > 0) then "\n" else "") ++ (concatMap (((ind 2) ++) . printSlave) ds) ++ ind 1 ++ "end type " ++ printSlave n ++ "\n\n" printMaster (MeasureUnitDef _ _ ds) = ind 1 ++ "unit :: " ++ (concat . intersperse ", " . map showDU) ds ++ "\n" printMaster (Include _ i) = "include "++printSlave i printMaster (DSeq _ d d') = printSlave d++printSlave d' printMaster (NullDecl _ _) = "" +printMasterInterfaceSpecs xs = concat $ intersperse "\n" (map printMaster xs) + show_namelist ((x,xs):[]) = "/" ++ printSlave x ++ "/" ++ (concat (intersperse ", " (map printSlave xs))) show_namelist ((x,xs):ys) = "/" ++ printSlave x ++ "/" ++ (concat (intersperse ", " (map printSlave xs))) ++ "," ++ show_namelist ys show_data ((xs,ys)) = "/" ++ printSlave xs ++ "/" ++ printSlave ys @@ -236,9 +240,6 @@ instance (PrintSlave (Arg p) v, PrintSlave (BinOp p) v, PrintSlave (Expr p) v, P printMaster (GOper _ op) = "operator("++printSlave op++")" printMaster (GAssg _) = "assignment(=)" -instance (PrintMaster (InterfaceSpec p) v) => PrintMaster [InterfaceSpec p] v where - printMaster xs = concat $ intersperse "\n" (map printMaster xs) - instance (PrintSlave (Arg p) v, PrintSlave (Decl p) v, PrintSlave (Implicit p) v, PrintSlave (SubName p) v, PPVersion v) => PrintMaster (InterfaceSpec p) v where printMaster (FunctionInterface _ s as us i ds) = (ind 1)++ "function " ++ printSlave s ++ printSlave as ++ showUse us ++ printSlave i ++ printSlave ds ++ "\nend function " ++ printSlave s From f1e8615cfb53a76adc34ccddf56bbe17e4f74959 Mon Sep 17 00:00:00 2001 From: Dominic Date: Mon, 27 Jul 2015 18:44:55 +0100 Subject: [PATCH 10/20] fixed default pretty printing of measure units --- src/Language/Fortran/Pretty.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Language/Fortran/Pretty.hs b/src/Language/Fortran/Pretty.hs index 1830a30..cbb3e76 100644 --- a/src/Language/Fortran/Pretty.hs +++ b/src/Language/Fortran/Pretty.hs @@ -47,11 +47,9 @@ instance (PrintMaster t DefaultPP) => PrintSlave t DefaultPP where instance (PrintIndMaster t DefaultPP) => PrintIndSlave t DefaultPP where printIndSlave = printIndMaster --- Behaviour's that all slaves must have i.e., for all versions v - +-- Behaviours that all slaves must have, i.e., for all versions v instance PPVersion v => PrintSlave Char v where printSlave = show - instance PPVersion v => PrintSlave String v where printSlave = id @@ -59,7 +57,10 @@ instance PPVersion v => PrintSlave String v where -- Printing declarations -instance (PPVersion v, PrintSlave a v) => PrintMaster [a] v where +instance PPVersion v => PrintMaster String v where + printMaster = id + +instance (PPVersion v, PrintSlave (ProgUnit p) v) => PrintMaster [ProgUnit p] v where printMaster xs = concat $ intersperse "\n" (map printSlave xs) instance (PrintSlave (Arg p) v, From d83679841cf34a4f02aecc94aad6d9472aad3ac5 Mon Sep 17 00:00:00 2001 From: Dominic Date: Mon, 27 Jul 2015 18:48:08 +0100 Subject: [PATCH 11/20] removed default char instance + some comments --- src/Language/Fortran/Pretty.hs | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/src/Language/Fortran/Pretty.hs b/src/Language/Fortran/Pretty.hs index cbb3e76..97243d2 100644 --- a/src/Language/Fortran/Pretty.hs +++ b/src/Language/Fortran/Pretty.hs @@ -41,22 +41,19 @@ class PrintIndSlave t v where class PrintIndMaster t v where printIndMaster :: (?variant :: v) => Int -> t -> String --- Default slave behaviour +-- | Default slave behaviour instance (PrintMaster t DefaultPP) => PrintSlave t DefaultPP where printSlave = printMaster instance (PrintIndMaster t DefaultPP) => PrintIndSlave t DefaultPP where printIndSlave = printIndMaster --- Behaviours that all slaves must have, i.e., for all versions v -instance PPVersion v => PrintSlave Char v where - printSlave = show +-- | Behaviours that all slaves must have, i.e., for all versions v instance PPVersion v => PrintSlave String v where printSlave = id -------------------------------------------------------------------------- --- Printing declarations - +-- | Definition of the master pretty printer which, notably, is defined for all versions 'v'. instance PPVersion v => PrintMaster String v where printMaster = id From 05fba16e08fefdf25a77cd14739ff38a27b0dcf9 Mon Sep 17 00:00:00 2001 From: Dominic Date: Wed, 28 Oct 2015 16:15:37 +0000 Subject: [PATCH 12/20] cabal updated --- language-fortran.cabal | 2 +- src/Language/Fortran/Pretty.hs | 2 -- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/language-fortran.cabal b/language-fortran.cabal index e53447b..9e85b0c 100644 --- a/language-fortran.cabal +++ b/language-fortran.cabal @@ -1,5 +1,5 @@ name: language-fortran -version: 0.3.1 +version: 0.4 synopsis: Fortran lexer and parser, language support, and extensions. description: Lexer and parser for Fortran roughly supporting standards from diff --git a/src/Language/Fortran/Pretty.hs b/src/Language/Fortran/Pretty.hs index 97243d2..00210bf 100644 --- a/src/Language/Fortran/Pretty.hs +++ b/src/Language/Fortran/Pretty.hs @@ -171,8 +171,6 @@ show_namelist ((x,xs):[]) = "/" ++ printSlave x ++ "/" ++ (concat (intersperse " show_namelist ((x,xs):ys) = "/" ++ printSlave x ++ "/" ++ (concat (intersperse ", " (map printSlave xs))) ++ "," ++ show_namelist ys show_data ((xs,ys)) = "/" ++ printSlave xs ++ "/" ++ printSlave ys --- showDV :: (Expr,Expr) -> String - showDV (v, NullExpr _ _, Just n) = (printMaster v) ++ "*" ++ show n showDV (v, NullExpr _ _, Nothing) = printMaster v showDV (v,e,Nothing) = printMaster v++" = "++printMaster e From 8128a4bcccdc63197172f474a56e864e972764ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=CF=88=EF=BC=88=E3=83=97=E3=82=B5=E3=82=A4=EF=BC=89?= Date: Fri, 27 Nov 2015 23:55:19 +0900 Subject: [PATCH 13/20] here is the f90 spec: ftp://ftp.nag.co.uk/sc22wg5/n001-n1100/n692.pdf implements: - 11.3.2 The USE statement and use association use statements with "only" keyword. improve: - 3.3.1.3 Free form statement continuation We must ignore the whole comment line (including \n) --- src/Language/Fortran.hs | 76 ++++---- src/Language/Fortran/Lexer.x | 20 +- src/Language/Fortran/Parser.y | 331 +++++++++++++++++---------------- src/Language/Fortran/Pretty.hs | 93 ++++----- 4 files changed, 268 insertions(+), 252 deletions(-) diff --git a/src/Language/Fortran.hs b/src/Language/Fortran.hs index 6d7f936..24c2a07 100644 --- a/src/Language/Fortran.hs +++ b/src/Language/Fortran.hs @@ -53,8 +53,8 @@ type ProgName = String data SubName p = SubName p String | NullSubName p deriving (Show, Functor, Typeable, Data, Eq) - -data VarName p = VarName p Variable + +data VarName p = VarName p Variable deriving (Show, Functor, Typeable, Data, Eq, Read) data ArgName p = ArgName p String @@ -74,7 +74,7 @@ data ArgList p = ArgList p (Expr p) type Program p = [ProgUnit p] - -- Prog type (type of result) name args (result) body use's + -- Prog type (type of result) name args (result) body use's data ProgUnit p = Main p SrcSpan (SubName p) (Arg p) (Block p) [ProgUnit p] | Sub p SrcSpan (Maybe (BaseType p)) (SubName p) (Arg p) (Block p) | Function p SrcSpan (Maybe (BaseType p)) (SubName p) (Arg p) (Maybe (VarName p)) (Block p) @@ -85,18 +85,22 @@ data ProgUnit p = Main p SrcSpan (SubName p) (Arg p) | IncludeProg p SrcSpan (Decl p) (Maybe (Fortran p)) deriving (Show, Functor, Typeable, Data, Eq) --- | Implicit none or no implicit -data Implicit p = ImplicitNone p | ImplicitNull p +-- | Implicit none or no implicit +data Implicit p = ImplicitNone p | ImplicitNull p deriving (Show, Functor, Typeable, Data, Eq) --- | renames for "use"s +-- | renames for "use"s type Renames = [(Variable, Variable)] data UseBlock p = UseBlock (Uses p) SrcLoc deriving (Show, Functor, Typeable, Data, Eq) +data Use = Use String Renames + | UseOnly String [(Variable, Maybe Variable)] + deriving (Show, Typeable, Data, Eq) + -- | (second 'p' let's you annotate the 'cons' part of the cell) -data Uses p = Use p (String, Renames) (Uses p) p - | UseNil p deriving (Show, Functor, Typeable, Data, Eq) +data Uses p = Uses p Use (Uses p) p + | UseNil p deriving (Show, Functor, Typeable, Data, Eq) -- use's implicit decls stmts data Block p = Block p (UseBlock p) (Implicit p) SrcSpan (Decl p) (Fortran p) @@ -106,7 +110,7 @@ data Decl p = Decl p SrcSpan [(Expr p, Expr p, Maybe Int)] (Type p | Namelist p [(Expr p, [Expr p])] -- namelist declaration | DataDecl p (DataForm p) | Equivalence p SrcSpan [(Expr p)] - | AttrStmt p (Attr p) [(Expr p, Expr p, Maybe Int)] + | AttrStmt p (Attr p) [(Expr p, Expr p, Maybe Int)] | AccessStmt p (Attr p) [GSpec p] -- access stmt | ExternalStmt p [String] -- external stmt | Interface p (Maybe (GSpec p)) [InterfaceSpec p] -- interface declaration @@ -120,7 +124,7 @@ data Decl p = Decl p SrcSpan [(Expr p, Expr p, Maybe Int)] (Type p | MeasureUnitDef p SrcSpan [(MeasureUnit, MeasureUnitSpec p)] deriving (Show, Functor, Typeable, Data, Eq) - -- BaseType dimensions type Attributes kind len + -- BaseType dimensions type Attributes kind len data Type p = BaseType p (BaseType p) [Attr p] (Expr p) (Expr p) | ArrayT p [(Expr p, Expr p)] (BaseType p) [Attr p] (Expr p) (Expr p) deriving (Show, Functor, Typeable, Data, Eq) @@ -133,7 +137,7 @@ data BaseType p = Integer p | Real p | DoublePrecision p | Character p data Attr p = Parameter p | Allocatable p | External p - | Intent p (IntentAttr p) + | Intent p (IntentAttr p) | Intrinsic p | Optional p | Pointer p @@ -147,7 +151,7 @@ data Attr p = Parameter p -- units-of-measure extension | MeasureUnit p (MeasureUnitSpec p) deriving (Show, Functor, Typeable, Data, Eq) - + {- start: units-of-measure extension -} type MeasureUnit = String @@ -166,20 +170,20 @@ data Fraction p = IntegerConst p String data GSpec p = GName p (Expr p) | GOper p (BinOp p) | GAssg p deriving (Show, Functor, Typeable, Data, Eq) - + data InterfaceSpec p = FunctionInterface p (SubName p) (Arg p) (Uses p) (Implicit p) (Decl p) | SubroutineInterface p (SubName p) (Arg p) (Uses p) (Implicit p) (Decl p) | ModuleProcedure p [(SubName p)] deriving (Show, Functor, Typeable, Data, Eq) - + data DataForm p = Data p [(Expr p, Expr p)] deriving (Show, Functor, Typeable, Data, Eq) -- data declaration - + data IntentAttr p = In p | Out p | InOut p deriving (Show, Functor, Typeable, Data, Eq) - -data Fortran p = Assg p SrcSpan (Expr p) (Expr p) + +data Fortran p = Assg p SrcSpan (Expr p) (Expr p) | For p SrcSpan (VarName p) (Expr p) (Expr p) (Expr p) (Fortran p) | DoWhile p SrcSpan (Expr p) (Fortran p) | FSeq p SrcSpan (Fortran p) (Fortran p) @@ -189,7 +193,7 @@ data Fortran p = Assg p SrcSpan (Expr p) (Expr p) | Call p SrcSpan (Expr p) (ArgList p) | Open p SrcSpan [Spec p] | Close p SrcSpan [Spec p] - | Continue p SrcSpan + | Continue p SrcSpan | Cycle p SrcSpan String | DataStmt p SrcSpan (DataForm p) | Deallocate p SrcSpan [(Expr p)] (Expr p) @@ -224,7 +228,7 @@ data Expr p = Con p SrcSpan String | Unary p SrcSpan (UnaryOp p) (Expr p) | CallExpr p SrcSpan (Expr p) (ArgList p) | NullExpr p SrcSpan - | Null p SrcSpan + | Null p SrcSpan | ESeq p SrcSpan (Expr p) (Expr p) | Bound p SrcSpan (Expr p) (Expr p) | Sqrt p SrcSpan (Expr p) @@ -262,7 +266,7 @@ data Spec p = Access p (Expr p) | ExFile p (Expr p) | Exist p (Expr p) | Eor p (Expr p) - | File p (Expr p) + | File p (Expr p) | FMT p (Expr p) | Form p (Expr p) | Formatted p (Expr p) @@ -276,20 +280,20 @@ data Spec p = Access p (Expr p) | Floating p (Expr p) (Expr p) | NextRec p (Expr p) | NML p (Expr p) - | Opened p (Expr p) + | Opened p (Expr p) | Pad p (Expr p) | Position p (Expr p) | Read p (Expr p) | ReadWrite p (Expr p) - | Rec p (Expr p) - | Recl p (Expr p) + | Rec p (Expr p) + | Recl p (Expr p) | Sequential p (Expr p) | Size p (Expr p) | Status p (Expr p) - | StringLit p String + | StringLit p String | Unit p (Expr p) | WriteSp p (Expr p) - | Delimiter p + | Delimiter p deriving (Show, Functor,Typeable,Data, Eq) -- Extract span information from the source tree @@ -343,7 +347,7 @@ instance Span (Fortran a) where srcSpan (Backspace x sp _) = sp srcSpan (Call x sp e as) = sp srcSpan (Open x sp s) = sp - srcSpan (Close x sp s) = sp + srcSpan (Close x sp s) = sp srcSpan (Continue x sp) = sp srcSpan (Cycle x sp s) = sp srcSpan (DataStmt x sp _) = sp @@ -356,9 +360,9 @@ instance Span (Fortran a) where srcSpan (Nullify x sp e) = sp srcSpan (Inquire x sp s e) = sp srcSpan (Pause x sp _) = sp - srcSpan (Rewind x sp s) = sp + srcSpan (Rewind x sp s) = sp srcSpan (Stop x sp e) = sp - srcSpan (Where x sp e f _) = sp + srcSpan (Where x sp e f _) = sp srcSpan (Write x sp s e) = sp srcSpan (PointerAssg x sp e1 e2) = sp srcSpan (Return x sp e) = sp @@ -368,10 +372,10 @@ instance Span (Fortran a) where srcSpan (TextStmt x sp s) = sp srcSpan (NullStmt x sp) = sp --- Extract the tag +-- Extract the tag class Tagged d where - tag :: d a -> a + tag :: d a -> a instance Tagged Attr where tag (Parameter x) = x @@ -412,14 +416,14 @@ instance Tagged Implicit where tag (ImplicitNone x) = x tag (ImplicitNull x) = x -instance Tagged Uses where - tag (Use x _ _ _) = x +instance Tagged Uses where + tag (Uses x _ _ _) = x tag (UseNil x) = x instance Tagged Arg where tag (Arg x _ _) = x -instance Tagged ArgList where +instance Tagged ArgList where tag (ArgList x _) = x instance Tagged ArgName where @@ -466,7 +470,7 @@ instance Tagged Fortran where tag (Backspace x sp _) = x tag (Call x sp e as) = x tag (Open x sp s) = x - tag (Close x sp s) = x + tag (Close x sp s) = x tag (Continue x sp) = x tag (Cycle x sp s) = x tag (DataStmt x sp _) = x @@ -479,9 +483,9 @@ instance Tagged Fortran where tag (Nullify x sp e) = x tag (Inquire x sp s e) = x tag (Pause x sp _) = x - tag (Rewind x sp s) = x + tag (Rewind x sp s) = x tag (Stop x sp e) = x - tag (Where x sp e f _) = x + tag (Where x sp e f _) = x tag (Write x sp s e) = x tag (PointerAssg x sp e1 e2) = x tag (Return x sp e) = x diff --git a/src/Language/Fortran/Lexer.x b/src/Language/Fortran/Lexer.x index 95050db..eea5e9a 100644 --- a/src/Language/Fortran/Lexer.x +++ b/src/Language/Fortran/Lexer.x @@ -31,7 +31,7 @@ $alphanumeric_charactor = [$letter $digit $underscore $currency_symbol $at_sign] @name = ($letter | $underscore) ($letter | $digit | $underscore | $currency_symbol | $at_sign)* @digit_string = $digit+ @signed_digit_string = $sign? @digit_string -@line_space = ($white # \n)* +@line_space = ($white # \n)* @kind_param = @digit_string | @name @int_literal_constant = @digit_string (\_ @kind_param)? @@ -44,7 +44,7 @@ $alphanumeric_charactor = [$letter $digit $underscore $currency_symbol $at_sign] @e = @int_literal_constant @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" -@continuation_line_alt = \n$white*"&" | \n$white*"$" | \n$white*"+" +@continuation_line_alt = \n$white*"&" | \n$white*"$" | \n$white*"+" @binary_constant_prefix = ("B" \' $digit+ \') | ("B" \" $digit+ \") @octal_constant_prefix = ("O" \' $digit+ \') | ("O" \" $digit+ \") @@ -110,11 +110,11 @@ tokens :- "$" { \s -> Dollar } "NULL()" { \s -> Key "null" } -- "&" ; -- ignore & anywhere - @continuation_line_alt { \s -> ContLineAlt } + @continuation_line_alt { \s -> ContLineAlt } \n "!".* \n $white*"&" { \s -> ContLineWithComment } $white*"&"$white*\n { \s -> ContLine } -- ignore & and spaces followed by '\n' (continuation line) - ($white # \r # \n)*"&" { \s -> ContLineNoNewLine } - "!".*$ ; + ($white # \r # \n)*"&" { \s -> ContLineNoNewLine } + "!".*\n ; "%" { \s -> Percent } "{" { \s -> LBrace } "}" { \s -> RBrace } @@ -139,13 +139,13 @@ tokens :- { -- Each action has type :: String -> Token - + -- Fixes continuation lines in the middle of strings - removes the continuation line part cutOutContLine cs = [head cs] ++ (reverse (cutOut cs' (Just []))) ++ [head cs] where cs' = (take (length cs - 2) (drop 1 cs)) cutOut [] Nothing = [] -cutOut [] (Just xs) = xs +cutOut [] (Just xs) = xs cutOut ('&':cs) Nothing = cutOut cs (Just []) cutOut ('$':cs) Nothing = cutOut cs (Just []) cutOut ('+':cs) Nothing = cutOut cs (Just []) @@ -158,7 +158,7 @@ cutOut (c:cs) (Just xs) = cutOut cs (Just (c:xs)) -- The token type: data Token = Key String | LitConst Char String | OpPower | OpMul | OpDiv | OpAdd | OpSub | OpConcat - | OpEQ | OpNE | OpLT | OpLE | OpGT | OpGE | OpLG + | OpEQ | OpNE | OpLT | OpLE | OpGT | OpGE | OpLG | OpNOT | OpAND | OpOR | OpXOR | OpEQV | OpNEQV | BinConst String | OctConst String | HexConst String | ID String | Num String | Comma | Bang | Percent @@ -211,10 +211,10 @@ lexer :: (Token -> P a) -> P a lexer = runL lexer' lexer' :: Lex a Token -lexer' = do s <- getInput +lexer' = do s <- getInput startToken case alexScan ('\0',[],s) 0 of - AlexEOF -> return TokEOF + AlexEOF -> return TokEOF AlexError (c,b,s') -> getInput >>= (\i -> fail ("unrecognizable token: " ++ show c ++ "(" ++ (show $ ord c) ++ "). ")) AlexSkip (_,b,s') len -> discard len >> lexer' AlexToken (_,b,s') len act -> do let tok = act (take len s) diff --git a/src/Language/Fortran/Parser.y b/src/Language/Fortran/Parser.y index 11f7dd4..a1a4a11 100644 --- a/src/Language/Fortran/Parser.y +++ b/src/Language/Fortran/Parser.y @@ -17,7 +17,7 @@ import Language.Fortran import Language.Fortran.PreProcess import qualified Language.Haskell.Syntax as LH (SrcLoc(..)) -import Language.Haskell.ParseMonad +import Language.Haskell.ParseMonad import Language.Fortran.Lexer import Data.Char (toLower) import Debug.Trace @@ -74,7 +74,7 @@ import Debug.Trace --'Z' { LitMark $$ } --'o' { LitMark $$ } --'O' { LitMark $$ } --- OBSOLETE '!' { Bang } +-- OBSOLETE '!' { Bang } '%' { Percent } '$' { Dollar } -- OBSOLETE '!{' { StopParamStart } @@ -137,7 +137,7 @@ import Debug.Trace NONE { Key "none" } NULLIFY { Key "nullify" } NULL { Key "null" } --- ONLY { Key "only" } + ONLY { Key "only" } OPEN { Key "open" } OPERATOR { Key "operator" } OPTIONAL { Key "optional" } @@ -187,14 +187,14 @@ import Debug.Trace %% include_program :: { Program A0 } -include_program -: srcloc newline specification_part_top {% do { s <- getSrcSpan $1; +include_program +: srcloc newline specification_part_top {% do { s <- getSrcSpan $1; return [IncludeProg () s $3 Nothing] }} executable_program :: { Program A0 } executable_program : program_unit_list { $1 } - + program_unit_list :: { Program A0 } program_unit_list : program_unit_list newline0 program_unit { $1++[$3] } @@ -208,21 +208,21 @@ program_unit | block_data { $1 } plist :: { [String] } -plist +plist : plist ',' id2 { $1++[$3] } | id2 { [$1] } vlist :: { [Expr A0] } -vlist +vlist : variable ',' vlist { $1:$3 } | variable { [$1] } newline :: {} -newline : '\n' newline0 {} +newline : '\n' newline0 {} -- | ';' newline0 {} newline0 :: {} -newline0 : newline {} +newline0 : newline {} | {- empty -} {} main_program :: { ProgUnit A0 } @@ -238,7 +238,7 @@ main_program program_stmt :: { (SubName A0, Arg A0) } program_stmt : PROGRAM subname args_p newline { ($2, $3) } - | PROGRAM subname srcloc newline { ($2, (Arg () (NullArg ())) ($3, $3)) } + | PROGRAM subname srcloc newline { ($2, (Arg () (NullArg ())) ($3, $3)) } end_program_stmt :: { String } end_program_stmt @@ -254,10 +254,10 @@ implicit_part external_subprogram :: { ProgUnit A0} external_subprogram : function_subprogram { $1 } - | subroutine_subprogram { $1 } + | subroutine_subprogram { $1 } subroutine_subprogram :: { ProgUnit A0 } -subroutine_subprogram +subroutine_subprogram : srcloc subroutine_stmt srcloc use_stmt_list implicit_part srcloc specification_part_top execution_part end_subroutine_stmt newline0 {% do { s <- getSrcSpan $1; s' <- getSrcSpan $6; @@ -285,22 +285,22 @@ function_subprogram block_data :: { ProgUnit A0 } block_data - : srcloc block_data_stmt use_stmt_list implicit_part specification_part_top end_block_data_stmt + : srcloc block_data_stmt use_stmt_list implicit_part specification_part_top end_block_data_stmt {% do { s <- getSrcSpan $1; name <- cmpNames $2 $6 "block data"; return (BlockData () s name $3 $4 $5); } } - + block_data_stmt :: { SubName A0 } block_data_stmt - : BLOCK DATA subname { $3 } - | BLOCK DATA { "foobar" `trace` NullSubName () } + : BLOCK DATA subname { $3 } + | BLOCK DATA { "foobar" `trace` NullSubName () } end_block_data_stmt :: { String } end_block_data_stmt : END BLOCK DATA id2 { $4 } | END BLOCK DATA { "" } | END { "" } - + module :: { ProgUnit A0 } module : srcloc module_stmt use_stmt_list implicit_part specification_part_top module_subprogram_part end_module_stmt newline0 @@ -310,7 +310,7 @@ module module_stmt :: { SubName A0 } module_stmt - : MODULE subname newline { $2 } + : MODULE subname newline { $2 } end_module_stmt :: { String } end_module_stmt @@ -321,34 +321,41 @@ end_module_stmt module_subprogram_part :: { Program A0 } module_subprogram_part : CONTAINS newline internal_subprogram_list { $3 } -| {- empty -} { [] } - +| {- empty -} { [] } + internal_subprogram_list :: { Program A0 } internal_subprogram_list - : internal_subprogram_list internal_subprogram newline0 { $1++[$2] } + : internal_subprogram_list internal_subprogram newline0 { $1++[$2] } | {- empty -} { [] } - + internal_subprogram :: { ProgUnit A0 } internal_subprogram : subroutine_subprogram { $1 } | function_subprogram { $1 } - + use_stmt_list :: { Uses A0 } use_stmt_list -: use_stmt use_stmt_list { Use () $1 $2 () } +: use_stmt use_stmt_list { Uses () $1 $2 () } | {- empty -} { UseNil () } -use_stmt :: { (String, Renames) } +use_stmt :: { Use } use_stmt -: USE id2 newline { ($2, []) } -| USE COMMON ',' renames newline { ("common", $4) } -- Since "common" is a valid module name -| USE id2 ',' renames newline { ($2, $4) } +: USE id2 newline { (Use $2 []) } +| USE COMMON ',' renames newline { (Use "common" $4) } -- Since "common" is a valid module name +| USE id2 ',' renames newline { (Use $2 $4) } +| USE COMMON ',' ONLY ':' only_list newline { (UseOnly "common" $6) } -- Since "common" is a valid module name +| USE id2 ',' ONLY ':' only_list newline { (UseOnly $2 $6) } + +only_list :: { [(Variable, Maybe Variable)] } +: id2 '=>' id2 { [($1, Just $3)] } + | id2 { [($1, Nothing)] } + | only_list ',' only_list { $1 ++ $3 } renames :: { [(Variable, Variable)] } : id2 '=>' id2 { [($1, $3)] } | renames ',' renames { $1 ++ $3 } - - + + -- [DO: Allows the specification part of a module to be empty] specification_part_top :: { Decl A0 } specification_part_top @@ -359,7 +366,7 @@ specification_part :: { Decl A0 } specification_part : declaration_construct_l specification_part { DSeq () $1 $2 } | declaration_construct_l { $1 } - + declaration_construct_l :: { Decl A0 } declaration_construct_l @@ -376,12 +383,12 @@ declaration_construct_p declaration_construct :: { Decl A0 } declaration_construct - : srcloc type_spec_p attr_spec_list '::' entity_decl_list - {% (getSrcSpan $1) >>= (\s -> return $ if null (fst $3) + : srcloc type_spec_p attr_spec_list '::' entity_decl_list + {% (getSrcSpan $1) >>= (\s -> return $ if null (fst $3) then Decl () s $5 ((BaseType () (fst3 $2) (snd $3) (snd3 $2) (trd3 $2))) else Decl () s $5 ((ArrayT () (fst $3) (fst3 $2) (snd $3) (snd3 $2) (trd3 $2)))) } - | srcloc type_spec_p attr_spec_list entity_decl_list - {% (getSrcSpan $1) >>= (\s -> return $ if null (fst $3) + | srcloc type_spec_p attr_spec_list entity_decl_list + {% (getSrcSpan $1) >>= (\s -> return $ if null (fst $3) then Decl () s $4 ((BaseType () (fst3 $2) (snd $3) (snd3 $2) (trd3 $2))) else Decl () s $4 ((ArrayT () (fst $3) (fst3 $2) (snd $3) (snd3 $2) (trd3 $2)))) } | interface_block { $1 } @@ -402,11 +409,11 @@ entity_decl :: { (Expr A0, Expr A0, Maybe Int) } entity_decl -- : srcloc ID '=' expr {% getSrcSpan $1 >>= (\s -> return $ (Var () s [(VarName () $2,[])], $4, Nothing)) } : variable '=' expr { ($1, $3, Nothing) } -| variable {% getSrcSpanNull >>= (\s -> return $ ($1, NullExpr () s, Nothing)) } -| variable '*' num {% getSrcSpanNull >>= (\s -> return $ ($1, NullExpr () s, Just $ read $3)) } +| variable {% getSrcSpanNull >>= (\s -> return $ ($1, NullExpr () s, Nothing)) } +| variable '*' num {% getSrcSpanNull >>= (\s -> return $ ($1, NullExpr () s, Just $ read $3)) } + +-- | id2 {% getSrcSpanNull >>= (\s -> return $ (Var () s [(VarName () $1,[])], NullExpr () s, Nothing)) } --- | id2 {% getSrcSpanNull >>= (\s -> return $ (Var () s [(VarName () $1,[])], NullExpr () s, Nothing)) } - object_name :: { String } object_name @@ -432,7 +439,7 @@ type_spec | COMPLEX '*' length_value {% getSrcSpanNull >>= (\s -> return $ (Complex (), $3, NullExpr () s)) } | COMPLEX {% getSrcSpanNull >>= (\s -> return $ (Complex (),NullExpr () s, NullExpr () s)) } | CHARACTER char_selector { (Character (), snd $2, fst $2) } -| CHARACTER '*' length_value {% getSrcSpanNull >>= (\s -> return $ (Character (), $3, NullExpr () s)) } +| CHARACTER '*' length_value {% getSrcSpanNull >>= (\s -> return $ (Character (), $3, NullExpr () s)) } | CHARACTER {% getSrcSpanNull >>= (\s -> return $ (Character (), NullExpr () s, NullExpr () s)) } | LOGICAL kind_selector {% getSrcSpanNull >>= (\s -> return $ (Logical (), $2, NullExpr () s)) } | LOGICAL '*' length_value {% getSrcSpanNull >>= (\s -> return $ (Logical (), $3, NullExpr () s)) } @@ -440,14 +447,14 @@ type_spec | TYPE '(' type_name ')' {% getSrcSpanNull >>= (\s -> return $ (DerivedType () $3, NullExpr () s, NullExpr () s)) } -- | POINTER '(' pointer_name ',' pointee_name ['(' array_spec ')' ] ')' ---[',' '(' pointer_name ',' pointee_name ['(' array_spec ')' ] ')' ] +--[',' '(' pointer_name ',' pointee_name ['(' array_spec ')' ] ')' ] kind_selector :: { Expr A0 } : '(' KIND '=' expr ')' { $4 } | '(' expr ')' { $2 } char_selector :: { (Expr A0, Expr A0) } -- (LEN, KIND) -char_selector +char_selector : length_selector {% getSrcSpanNull >>= (\s -> return $ ($1,NullExpr () s)) } | '(' LEN '=' char_len_param_value ',' KIND '=' expr ')' { ($4,$8) } | '(' char_len_param_value ',' KIND '=' expr ')' { ($2,$6) } @@ -456,7 +463,7 @@ char_selector | '(' KIND '=' expr ')' {% getSrcSpanNull >>= (\s -> return $ (NullExpr () s,$4)) } length_selector :: { Expr A0 } -length_selector +length_selector : '(' LEN '=' char_len_param_value ')' { $4 } | '(' char_len_param_value ')' { $2 } @@ -555,7 +562,7 @@ signed_num :: { String } signed_num : '-' num { "-" ++ $2 } | num { $1 } - + -- end array_spec :: { [(Expr A0, Expr A0)] } @@ -569,7 +576,7 @@ explicit_shape_spec_list explicit_shape_spec :: { Expr A0 } explicit_shape_spec - : expr { $1 } + : expr { $1 } | bound { $1 } include_stmt :: { Decl A0 } @@ -577,7 +584,7 @@ include_stmt :: { Decl A0 } specification_expr :: { Expr A0 } specification_expr - : expr { $1 } + : expr { $1 } intent_spec :: { IntentAttr A0 } intent_spec @@ -602,7 +609,7 @@ specification_stmt -- | optional_stmt { $1 } -- | pointer_stmt { $1 } | save_stmt { $1 } --- | target_stmt { $1 } +-- | target_stmt { $1 } save_stmt :: { Decl A0 } : SAVE { AccessStmt () (Save ()) [] } @@ -620,42 +627,42 @@ interface_stmt :: { Maybe (GSpec A0) } interface_stmt : INTERFACE generic_spec { Just $2 } | INTERFACE { Nothing } - + interface_spec_list :: { [InterfaceSpec A0] } interface_spec_list : interface_spec_list interface_spec { $1++[$2] } | interface_spec { [$1] } - + interface_spec :: { InterfaceSpec A0 } interface_spec : interface_body { $1 } | module_procedure_stmt { $1 } - + end_interface_stmt :: { Maybe (GSpec A0) } end_interface_stmt : END INTERFACE generic_spec { Just $3 } | END INTERFACE { Nothing } -interface_body :: { InterfaceSpec A0 } +interface_body :: { InterfaceSpec A0 } interface_body - : function_stmt use_stmt_list implicit_part specification_part end_function_stmt + : function_stmt use_stmt_list implicit_part specification_part end_function_stmt {% do { name <- cmpNames (fst4 $1) $5 "interface declaration"; return (FunctionInterface () name (snd4 $1) $2 $3 $4); }} - | function_stmt end_function_stmt + | function_stmt end_function_stmt {% do { name <- cmpNames (fst4 $1) $2 "interface declaration"; s <- getSrcSpanNull; - return (FunctionInterface () name (snd4 $1) (UseNil ()) (ImplicitNull ()) (NullDecl () s)); } } + return (FunctionInterface () name (snd4 $1) (UseNil ()) (ImplicitNull ()) (NullDecl () s)); } } | subroutine_stmt use_stmt_list implicit_part specification_part end_subroutine_stmt {% do { name <- cmpNames (fst3 $1) $5 "interface declaration"; return (SubroutineInterface () name (snd3 $1) $2 $3 $4); } } - | subroutine_stmt end_subroutine_stmt + | subroutine_stmt end_subroutine_stmt {% do { name <- cmpNames (fst3 $1) $2 "interface declaration"; s <- getSrcSpanNull; return (SubroutineInterface () name (snd3 $1) (UseNil ()) (ImplicitNull ()) (NullDecl () s)); }} - + module_procedure_stmt :: { InterfaceSpec A0 } module_procedure_stmt : MODULE PROCEDURE sub_name_list { ModuleProcedure () $3 } @@ -686,7 +693,7 @@ end_type_stmt type_name :: { SubName A0 } type_name -: ID { SubName () $1 } +: ID { SubName () $1 } private_sequence_stmt :: { [Attr A0] } private_sequence_stmt @@ -695,7 +702,7 @@ private_sequence_stmt | PRIVATE { [Private ()] } | SEQUENCE { [Sequence ()] } | {- empty -} { [] } - + component_def_stmt_list :: { [Decl A0 ] } component_def_stmt_list : component_def_stmt_list component_def_stmt { $1++[$2] } @@ -703,9 +710,9 @@ component_def_stmt_list component_def_stmt :: { Decl A0 } component_def_stmt - : srcloc type_spec_p component_attr_spec_list '::' entity_decl_list - {% (getSrcSpan $1) >>= (\s -> return $ - if null (fst $3) + : srcloc type_spec_p component_attr_spec_list '::' entity_decl_list + {% (getSrcSpan $1) >>= (\s -> return $ + if null (fst $3) then Decl () s $5 ((BaseType () (fst3 $2) (snd $3) (snd3 $2) (trd3 $2))) else Decl () s $5 ((ArrayT () (fst $3) (fst3 $2) (snd $3) (snd3 $2) (trd3 $2)))) } @@ -720,40 +727,40 @@ component_attr_spec | dim_spec { ($1,[]) } attr_stmt :: { Decl A0 } -attr_stmt : attr_spec_p '(' entity_decl_list ')' { AttrStmt () (head $ snd $1) ($3 ++ (map (\(x, y) -> (x, y, Nothing)) (fst $1))) } - | attr_spec_p { AttrStmt () (head $ snd $1) ((map (\(x, y) -> (x, y, Nothing)) (fst $1))) } -| dim_spec_p { AttrStmt () (Dimension () $1) [] } +attr_stmt : attr_spec_p '(' entity_decl_list ')' { AttrStmt () (head $ snd $1) ($3 ++ (map (\(x, y) -> (x, y, Nothing)) (fst $1))) } + | attr_spec_p { AttrStmt () (head $ snd $1) ((map (\(x, y) -> (x, y, Nothing)) (fst $1))) } +| dim_spec_p { AttrStmt () (Dimension () $1) [] } access_stmt :: { Decl A0 } access_stmt : access_spec '::' access_id_list { AccessStmt () $1 $3 } | access_spec access_id_list { AccessStmt () $1 $2 } | access_spec { AccessStmt () $1 [] } - + access_id_list :: { [GSpec A0] } access_id_list : access_id_list ',' access_id { $1++[$3] } | access_id { [$1] } access_id :: { GSpec A0 } -access_id +access_id : generic_spec { $1 } - + generic_spec :: { GSpec A0 } generic_spec -: srcloc ID {% getSrcSpan $1 >>= (\s -> return $ GName () (Var () s [(VarName () $2,[])])) } +: srcloc ID {% getSrcSpan $1 >>= (\s -> return $ GName () (Var () s [(VarName () $2,[])])) } | OPERATOR '(' defined_operator ')' { GOper () $3 } | ASSIGNMENT '(' '=' ')' { GAssg () } - + data_stmt :: { DataForm A0 } data_stmt : DATA data_stmt_set_list { Data () $2 } - + data_stmt_set_list :: { [(Expr A0, Expr A0)] } data_stmt_set_list : data_stmt_set_list ',' data_stmt_set { $1++[$3] } | data_stmt_set { [$1] } - + data_stmt_set :: { (Expr A0, Expr A0) } data_stmt_set : data_stmt_object_list '/' data_stmt_value_list '/' { ($1,$3) } @@ -766,7 +773,7 @@ data_stmt_object_list data_stmt_object :: { Expr A0 } data_stmt_object : variable { $1 } - + data_stmt_value_list :: { Expr A0 } data_stmt_value_list @@ -776,13 +783,13 @@ data_stmt_value_list data_stmt_value :: { Expr A0 } data_stmt_value : primaryP { $1 } - - + + external_stmt :: { Decl A0 } external_stmt : EXTERNAL '::' name_list { ExternalStmt () $3 } | EXTERNAL name_list { ExternalStmt () $2 } - + name_list :: { [String] } name_list : name_list ',' id2 { $1++[$3] } @@ -798,10 +805,10 @@ id_keywords : COMMON { "common" } -- allow common as a subname (can happen) | id_keywords_2 { $1 } id_keywords_2 :: { String } -id_keywords_2 : IN { "in" } +id_keywords_2 : IN { "in" } | OUT { "out" } | LEN { "len" } - + defined_operator :: { BinOp A0 } defined_operator -- : defined_binary_op @@ -817,13 +824,13 @@ intrinsic_operator | rel_op { $1 } -- | '.NOT.' { Not () } | '.AND.' { And () } - | '.OR.' { Or () } + | '.OR.' { Or () } namelist_stmt :: { Decl A0 } namelist_stmt : NAMELIST namelist_list { Namelist () $2 } - + namelist_list :: { [(Expr A0, [Expr A0])] } namelist_list : namelist_list ',' '/' constant_p '/' namelist_group_object_list { $1++[($4,$6)] } @@ -833,26 +840,26 @@ namelist_group_object_list :: { [Expr A0] } namelist_group_object_list : namelist_group_object_list ',' constant_p { $1++[$3] } | constant_p { [$1] } - + subroutine_stmt :: { (SubName A0, Arg A0, Maybe (BaseType A0)) } subroutine_stmt : SUBROUTINE subname args_p newline { ($2,$3,Nothing) } | SUBROUTINE subname srcloc newline {% (getSrcSpan $3) >>= (\s -> return $ ($2,Arg () (NullArg ()) s,Nothing)) } | prefix SUBROUTINE subname args_p newline { ($3,$4,Just (fst3 $1)) } - + function_stmt :: { (SubName A0, Arg A0, Maybe (BaseType A0), Maybe (VarName A0)) } function_stmt : prefix FUNCTION subname args_p RESULT '(' id2 ')' newline { ($3,$4,Just (fst3 $1),Just (VarName () $7)) } | prefix FUNCTION subname args_p newline { ($3,$4,Just (fst3 $1),Nothing) } | FUNCTION subname args_p RESULT '(' id2 ')' newline { ($2,$3,Nothing,Just (VarName () $6)) } | FUNCTION subname args_p newline { ($2,$3,Nothing,Nothing) } - + subname :: { SubName A0 } subname : ID { SubName () $1 } | id_keywords { SubName () $1 } - + prefix :: { (BaseType A0, Expr A0, Expr A0) } prefix : type_spec { $1 } @@ -869,7 +876,7 @@ dummy_arg_list : dummy_arg_list2 { Arg () $1 } | {- empty -} { Arg () (NullArg ()) } -dummy_arg_list2 :: { ArgName A0 } +dummy_arg_list2 :: { ArgName A0 } dummy_arg_list2 : dummy_arg_list2 ',' dummy_arg { ASeq () $1 $3 } | dummy_arg { $1 } @@ -878,7 +885,7 @@ dummy_arg :: { ArgName A0 } dummy_arg : ID { ArgName () $1 } | '*' { ArgName () "*" } - + assignment_stmt :: { Fortran A0 } assignment_stmt : variable '=' expr { Assg () (spanTrans $1 $3) $1 $3 } @@ -903,10 +910,10 @@ scalar_variable_name : ID '(' section_subscript_list ')' { (VarName () $1, $3) } | ID '(' ')' {% getSrcSpanNull >>= (\s -> return $ (VarName () $1, [NullExpr () s])) } | ID { (VarName () $1, []) } -| id_keywords_2 {% getSrcSpanNull >>= (\s -> return $ (VarName () $1, [NullExpr () s])) } +| id_keywords_2 {% getSrcSpanNull >>= (\s -> return $ (VarName () $1, [NullExpr () s])) } -- | TYPE { (VarName () "type", []) } -- a bit of a hack but 'type' allowed as var name --- -- but causes REDUCE REDUCE conflicts! +-- -- but causes REDUCE REDUCE conflicts! -- bound comes through int_expr subscript :: { Expr A0 } @@ -925,7 +932,7 @@ section_subscript_list :: { [Expr A0] } section_subscript_list : section_subscript_list ',' section_subscript { $1++[$3] } | section_subscript { [$1] } - + section_subscript :: { Expr A0 } section_subscript : subscript { $1 } @@ -957,64 +964,64 @@ and_operand : level_4_expr { $1 } level_4_expr :: { Expr A0 } -level_4_expr +level_4_expr : level_4_expr rel_op level_3_expr { Bin () (spanTrans $1 $3) $2 $1 $3 } | level_3_expr { $1 } level_3_expr :: { Expr A0 } -level_3_expr +level_3_expr : level_3_expr '//' level_2_expr { Bin () (spanTrans $1 $3) (Concat ()) $1 $3 } | level_2_expr { $1 } level_2_expr :: { Expr A0 } -level_2_expr +level_2_expr : level_2_expr '+' add_operand { Bin () (spanTrans $1 $3) (Plus ()) $1 $3 } | level_2_expr '-' add_operand { Bin () (spanTrans $1 $3) (Minus ()) $1 $3 } | add_operand { $1 } add_operand :: { Expr A0 } -add_operand +add_operand : add_operand '*' mult_operand { Bin () (spanTrans $1 $3) (Mul ()) $1 $3 } | add_operand '/' mult_operand { Bin () (spanTrans $1 $3) (Div ()) $1 $3 } | mult_operand { $1 } mult_operand :: { Expr A0 } -mult_operand +mult_operand : level_1_expr '**' mult_operand { Bin () (spanTrans $1 $3) (Power ()) $1 $3 } | level_1_expr { $1 } level_1_expr :: { Expr A0 } -level_1_expr +level_1_expr : srcloc '-' primary {% getSrcSpan $1 >>= (\s -> return $ Unary () s (UMinus ()) $3) } | srcloc '.NOT.' primary {% getSrcSpan $1 >>= (\s -> return $ Unary () s (Not ()) $3) } | primary { $1 } primaryP :: { Expr A0 } -primaryP : +primaryP : srcloc num '*' primary {% getSrcSpan $1 >>= (\s -> return $ Bin () s (Mul ()) (Con () s $2) $4) } | srcloc '-' primary {% getSrcSpan $1 >>= (\s -> return $ Unary () s (UMinus ()) $3) } | primary { $1 } primary :: { Expr A0 } -primary +primary : constant { $1 } | variable { $1 } | srcloc type_cast '(' expr ')' {% getSrcSpan $1 >>= (\s -> return $ Var () s [(VarName () $2, [$4])]) } - + | array_constructor { $1 } | '(' expr ')' { $2 } | srcloc SQRT '(' expr ')' {% getSrcSpan $1 >>= (\s -> return $ Sqrt () s $4) } type_cast :: { String } -type_cast +type_cast : REAL { "REAL" } -- The following supports the type cast notioatn | INTEGER { "INTEGER" } | LOGICAL { "LOGICAL" } | CHARACTER { "CHARACTER" } - | DOUBLE_PRECISION { "DOUBLE PRECISION" } + | DOUBLE_PRECISION { "DOUBLE PRECISION" } -- Bit of a conflict here- not entirely sure when this is needed @@ -1024,37 +1031,37 @@ fields :: { [String] } fields : fields '.' id2 { $1++[$3] } | id2 { [$1] } - + array_constructor :: { Expr A0 } array_constructor -: srcloc '(/' expr_list '/)' {% getSrcSpan $1 >>= (\s -> return $ ArrayCon () s $3) } +: srcloc '(/' expr_list '/)' {% getSrcSpan $1 >>= (\s -> return $ ArrayCon () s $3) } expr_list :: { [Expr A0] } expr_list : expr_list ',' expr { $1++[$3] } | expr { [$1] } - + constant_p :: { Expr A0 } constant_p : constant_p2 { $1 } - + constant_p2 :: { Expr A0 } constant_p2 : srcloc ID {% getSrcSpan $1 >>= (\s -> return $ Var () s [(VarName () $2,[])]) } - + constant :: { Expr A0 } -constant +constant : literal_constant { $1 } literal_constant :: { Expr A0 } -literal_constant +literal_constant : srcloc num {% (getSrcSpan $1) >>= (\s -> return $ Con () s $2) } | srcloc ZLIT {% (getSrcSpan $1) >>= (\s -> return $ ConL () s 'z' $2) } | srcloc STR {% (getSrcSpan $1) >>= (\s -> return $ ConS () s $2) } | logical_literal_constant { $1 } --lit_mark :: { Char } ---lit_mark +--lit_mark --: 'z' { $1 } --| 'Z' { $1 } --| 'b' { $1 } @@ -1063,7 +1070,7 @@ literal_constant --| 'O' { $1 } logical_literal_constant :: { Expr A0 } -logical_literal_constant +logical_literal_constant : srcloc '.TRUE.' {% (getSrcSpan $1) >>= (\s -> return $ Con () s ".TRUE.") } | srcloc '.FALSE.' {% (getSrcSpan $1) >>= (\s -> return $ Con () s ".FALSE.") } @@ -1079,7 +1086,7 @@ int_expr :: { Expr A0 } int_expr : expr { $1 } -do_variable :: { VarName A0 } +do_variable :: { VarName A0 } do_variable : ID { VarName () $1 } @@ -1087,28 +1094,28 @@ do_construct :: { Fortran A0 } do_construct : block_do_construct { $1 } -block_do_construct :: { Fortran A0 } -block_do_construct -: srcloc nonlabel_do_stmt newline do_block {% getSrcSpan $1 >>= (\s -> return $ For () s (fst4 $2) (snd4 $2) (trd4 $2) (frh4 $2) $4) } +block_do_construct :: { Fortran A0 } +block_do_construct +: srcloc nonlabel_do_stmt newline do_block {% getSrcSpan $1 >>= (\s -> return $ For () s (fst4 $2) (snd4 $2) (trd4 $2) (frh4 $2) $4) } | srcloc DO WHILE '(' logical_expr ')' newline do_block {% getSrcSpan $1 >>= (\s -> return $ DoWhile () s $5 $8) } -| srcloc DO num ',' loop_control newline do_block_num +| srcloc DO num ',' loop_control newline do_block_num {% do { (fs, n) <- return $ $7; s <- getSrcSpan $1; - if (n == $3) then + if (n == $3) then return $ For () s (fst4 $5) (snd4 $5) (trd4 $5) (frh4 $5) fs else parseError "DO/END DO labels don't match" } } -| srcloc DO num loop_control newline do_block_num +| srcloc DO num loop_control newline do_block_num {% do { (fs, n) <- return $ $6; s <- getSrcSpan $1; - if (n == $3) then + if (n == $3) then return $ For () s (fst4 $4) (snd4 $4) (trd4 $4) (frh4 $4) fs else parseError "DO/END DO labels don't match" } } -| srcloc DO num loop_control newline do_block_cont +| srcloc DO num loop_control newline do_block_cont {% do { (fs, n) <- return $ $6; s <- getSrcSpan $1; - if (n == $3) then + if (n == $3) then return $ For () s (fst4 $4) (snd4 $4) (trd4 $4) (frh4 $4) fs else return $ NullStmt () s -- parseError $ "DO/CONTINUE labels don't match" -- NEEDS FIXING! } } @@ -1139,7 +1146,7 @@ do_block_num : line newline do_block_num { let (fs, n) = $3 in (FSeq () (spanTra do_block_cont :: { (Fortran A0, String) } -do_block_cont : +do_block_cont : num CONTINUE {% getSrcSpanNull >>= (\s -> return $ (NullStmt () s, $1)) } | line newline do_block_cont { let (fs, n) = $3 in (FSeq () (spanTrans $1 fs) $1 fs, n) } @@ -1150,14 +1157,14 @@ line : num executable_constructP {% getSrcSpanNull >>= (\s -> return $ Label end_do :: { } end_do : END DO {} -| ENDDO {} +| ENDDO {} block :: { Fortran A0 } block : executable_construct_list { $1 } - + execution_part :: { Fortran A0 } -execution_part +execution_part : executable_construct_list { $1 } executable_construct_list :: { Fortran A0 } @@ -1179,9 +1186,9 @@ executable_constructP | if_construct { $1 } | action_stmt { $1 } - + equivalence_stmt :: { Decl A0 } -equivalence_stmt +equivalence_stmt : srcloc EQUIVALENCE '(' vlist ')' {% getSrcSpan $1 >>= (\s -> return $ Equivalence () s $4) } action_stmt :: { Fortran A0 } @@ -1232,7 +1239,7 @@ call_stmt call_name :: { Expr A0 } call_name -: srcloc id2 {% (getSrcSpan $1) >>= (\s -> return $ Var () s [(VarName () $2,[])]) } +: srcloc id2 {% (getSrcSpan $1) >>= (\s -> return $ Var () s [(VarName () $2,[])]) } actual_arg_spec_list :: { Expr A0 } actual_arg_spec_list @@ -1261,12 +1268,12 @@ else_if_stmt : ELSE if_then_stmt { $2 } if_then_stmt :: { Expr A0 } -if_then_stmt +if_then_stmt : IF '(' logical_expr ')' THEN newline { $3 } - + else_if_then_stmt :: { Expr A0 } -else_if_then_stmt +else_if_then_stmt : ELSEIF '(' logical_expr ')' THEN newline { $3 } | ELSE IF '(' logical_expr ')' THEN newline { $4 } @@ -1278,23 +1285,23 @@ else_if_then_stmt if_construct :: { Fortran A0 } if_construct -: +: -- FORTRAN 77 numerical comparison IFs - srcloc IF '(' logical_expr ')' num ',' num ',' num + srcloc IF '(' logical_expr ')' num ',' num ',' num {% getSrcSpan $1 >>= (\s -> return $ If () s (Bin () s (RelLT ()) $4 (Con () s "0")) (Goto () s $6) [(Bin () s (RelEQ ()) $4 (Con () s "0"), (Goto () s $8)), (Bin () s (RelGT ()) $4 (Con () s "0"), (Goto () s $10))] Nothing) } -- Other If forms -| srcloc if_then_stmt block end_if_stmt +| srcloc if_then_stmt block end_if_stmt {% getSrcSpan $1 >>= (\s -> return $ If () s $2 $3 [] Nothing) } -| srcloc if_then_stmt block else_if_list end_if_stmt +| srcloc if_then_stmt block else_if_list end_if_stmt {% getSrcSpan $1 >>= (\s -> return $ If () s $2 $3 $4 Nothing) } -| srcloc if_then_stmt block else_if_list ELSE newline block end_if_stmt +| srcloc if_then_stmt block else_if_list ELSE newline block end_if_stmt {% getSrcSpan $1 >>= (\s -> return $ If () s $2 $3 $4 (Just $7)) } --| if_then_stmt block ELSE block end_if_stmt {% getSrcSpan $1 (\s -> If s $1 $2 [] (Just $4)) } @@ -1305,14 +1312,14 @@ if_construct --| if_then_stmt block END IF { (If $1 $2 [] Nothing) } --| if_then_stmt block ELSE block END IF { (If $1 $2 [] (Just $4)) } --- : if_then_stmt block ----- else_if_list --- else_opt +-- : if_then_stmt block +---- else_if_list +-- else_opt -- END IF { (If $1 $2 $3) } end_if_stmt :: {} end_if_stmt : END IF { } - | ENDIF { } + | ENDIF { } logical_expr :: { Expr A0 } @@ -1321,10 +1328,10 @@ logical_expr allocate_stmt :: { Fortran A0 } allocate_stmt - : srcloc ALLOCATE '(' allocation_list ',' STAT '=' variable ')' + : srcloc ALLOCATE '(' allocation_list ',' STAT '=' variable ')' {% getSrcSpan $1 >>= (\s -> return $ Allocate () s $4 $8) } - | srcloc ALLOCATE '(' allocation_list ')' + | srcloc ALLOCATE '(' allocation_list ')' {% getSrcSpanNull >>= (\e -> getSrcSpan $1 >>= (\s -> return $ Allocate () s $4 (NullExpr () e))) } @@ -1403,7 +1410,7 @@ close_spec :: { Spec A0 } close_spec : expr { NoSpec () $1 } | UNIT '=' expr { Unit () $3 } -- units-of-measure -| ID '=' expr +| ID '=' expr {% case (map (toLower) $1) of "iostat" -> return (IOStat () $3) "status" -> return (Status () $3) @@ -1424,7 +1431,7 @@ cycle_stmt deallocate_stmt :: { Fortran A0 } deallocate_stmt -: srcloc DEALLOCATE '(' allocate_object_list ',' STAT '=' variable ')' +: srcloc DEALLOCATE '(' allocate_object_list ',' STAT '=' variable ')' {% getSrcSpan $1 >>= (\s -> return $ Deallocate () s $4 $8) } | srcloc DEALLOCATE '(' allocate_object_list ')' @@ -1441,15 +1448,15 @@ exit_stmt | srcloc EXIT {% getSrcSpan $1 >>= (\s -> return $ Exit () s "") } forall_stmt :: { Fortran A0 } -forall_stmt -: srcloc FORALL forall_header forall_assignment_stmt +forall_stmt +: srcloc FORALL forall_header forall_assignment_stmt {% getSrcSpan $1 >>= (\s -> return $ Forall () s $3 $4) } - | srcloc FORALL forall_header newline forall_assignment_stmt_list forall_stmt_end + | srcloc FORALL forall_header newline forall_assignment_stmt_list forall_stmt_end {% getSrcSpan $1 >>= (\s -> return $ Forall () s $3 $5) } forall_stmt_end :: {} -forall_stmt_end +forall_stmt_end : END FORALL {} | {- empty -} {} @@ -1475,7 +1482,7 @@ forall_assignment_stmt forall_assignment_stmt_list :: { Fortran A0 } -forall_assignment_stmt_list +forall_assignment_stmt_list : forall_assignment_stmt newline forall_assignment_stmt_list { FSeq () (spanTrans $1 $3) $1 $3 } | forall_assignment_stmt newline { $1 } @@ -1490,9 +1497,9 @@ if_stmt inquire_stmt :: { Fortran A0 } inquire_stmt -: srcloc INQUIRE '(' inquire_spec_list ')' - {% getSrcSpan $1 >>= (\s -> return $ Inquire () s $4 []) } - | srcloc INQUIRE '(' IOLENGTH '=' variable ')' output_item_list +: srcloc INQUIRE '(' inquire_spec_list ')' + {% getSrcSpan $1 >>= (\s -> return $ Inquire () s $4 []) } + | srcloc INQUIRE '(' IOLENGTH '=' variable ')' output_item_list {% getSrcSpan $1 >>= (\s -> return $ Inquire () s [IOLength () $6] $8) } @@ -1576,7 +1583,7 @@ connect_spec_list connect_spec :: { Spec A0 } connect_spec : expr { NoSpec () $1 } -| UNIT '=' expr { Unit () $3 } +| UNIT '=' expr { Unit () $3 } | ID '=' expr {% case (map (toLower) $1) of "iostat" -> return (IOStat () $3) "file" -> return (File () $3) @@ -1651,15 +1658,15 @@ io_control_spec_list_d : {- -| '(/' ',' io_control_spec_list '/)' { ((Delimiter ()):$3) ++ [Delimiter ()] } +| '(/' ',' io_control_spec_list '/)' { ((Delimiter ()):$3) ++ [Delimiter ()] } | '(' io_control_spec_list '/)' { $2 ++ [Delimiter ()] } - '(/' ',' io_control_spec_list ',' '/)' { ((Delimiter ()):$3) ++ [Delimiter ()] } + '(/' ',' io_control_spec_list ',' '/)' { ((Delimiter ()):$3) ++ [Delimiter ()] } | '(' io_control_spec_list ',' '/)' { $2 ++ [Delimiter ()] } -} io_control_spec_list_d2 :: { [Spec A0] } -io_control_spec_list_d2 : +io_control_spec_list_d2 : io_control_spec ',' io_control_spec_list_d2 { $1 ++ $3 } | '/)' { [Delimiter ()] } | io_control_spec ')' { $1 } @@ -1667,13 +1674,13 @@ io_control_spec_list_d2 : io_control_spec_list :: { [Spec A0] } -io_control_spec_list : +io_control_spec_list : io_control_spec ',' io_control_spec_list { $1 ++ $3 } | io_control_spec { $1 } -- (unit, fmt = format), (rec, advance = expr), (nml, iostat, id = var), (err, end, eor = label) -io_control_spec :: { [Spec A0] } +io_control_spec :: { [Spec A0] } io_control_spec : --format { [NoSpec () $1] } '/' { [Delimiter ()] } @@ -1772,14 +1779,14 @@ stop_stmt stop_code :: { Expr A0 } stop_code : constant { $1 } - + where_stmt :: { Fortran A0 } where_stmt -: srcloc WHERE '(' mask_expr ')' where_assignment_stmt {% getSrcSpan $1 >>= (\s -> return $ Where () s $4 $6 Nothing) } -| srcloc WHERE '(' mask_expr ')' newline where_assignment_stmt {% getSrcSpan $1 >>= (\s -> return $ Where () s $4 $7 Nothing) } -| srcloc WHERE '(' mask_expr ')' newline where_assignment_stmt newline ELSEWHERE newline where_assignment_stmt +: srcloc WHERE '(' mask_expr ')' where_assignment_stmt {% getSrcSpan $1 >>= (\s -> return $ Where () s $4 $6 Nothing) } +| srcloc WHERE '(' mask_expr ')' newline where_assignment_stmt {% getSrcSpan $1 >>= (\s -> return $ Where () s $4 $7 Nothing) } +| srcloc WHERE '(' mask_expr ')' newline where_assignment_stmt newline ELSEWHERE newline where_assignment_stmt newline END WHERE {% getSrcSpan $1 >>= (\s -> return $ Where () s $4 $7 (Just $11)) } where_assignment_stmt :: { Fortran A0 } @@ -1807,7 +1814,7 @@ getSrcLoc' = do (LH.SrcLoc f l c) <- getSrcLoc -- Type of annotations -type A0 = () +type A0 = () getSrcSpan :: SrcLoc -> P (SrcLoc, SrcLoc) getSrcSpan l = do l' <- getSrcLoc' @@ -1848,7 +1855,7 @@ tokenFollows s = case alexScan ('\0',[],s) 0 of AlexToken (_,b,t) len _ -> take len s parse :: String -> Program A0 -parse p = case (runParser parser (pre_process p)) of +parse p = case (runParser parser (pre_process p)) of (ParseOk p) -> p (ParseFailed l e) -> error e diff --git a/src/Language/Fortran/Pretty.hs b/src/Language/Fortran/Pretty.hs index 00210bf..dce5e41 100644 --- a/src/Language/Fortran/Pretty.hs +++ b/src/Language/Fortran/Pretty.hs @@ -1,7 +1,7 @@ --- --- Pretty.hs - +-- +-- Pretty.hs - -- Based on code by Martin Erwig from Parameterized Fortran --- Fortran pretty printer +-- Fortran pretty printer {-# LANGUAGE ExistentialQuantification, FlexibleContexts, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, DeriveDataTypeable, QuasiQuotes, DeriveFunctor, ImplicitParams, OverlappingInstances, ConstraintKinds #-} @@ -19,11 +19,11 @@ pprint = let ?variant = DefaultPP in printMaster data DefaultPP = DefaultPP -- Default behaviour -- | The set of all types which can be used to switch between pretty printer versions -class PPVersion a +class PPVersion a instance PPVersion DefaultPP -- Pretty printable types predicate (aliases the PrintMaster constraint) -type PrettyPrintable t = PrintMaster t DefaultPP +type PrettyPrintable t = PrintMaster t DefaultPP -- | Master print behaviour class PrintMaster t v where @@ -47,7 +47,7 @@ instance (PrintMaster t DefaultPP) => PrintSlave t DefaultPP where instance (PrintIndMaster t DefaultPP) => PrintIndSlave t DefaultPP where printIndSlave = printIndMaster --- | Behaviours that all slaves must have, i.e., for all versions v +-- | Behaviours that all slaves must have, i.e., for all versions v instance PPVersion v => PrintSlave String v where printSlave = id @@ -60,11 +60,11 @@ instance PPVersion v => PrintMaster String v where instance (PPVersion v, PrintSlave (ProgUnit p) v) => PrintMaster [ProgUnit p] v where printMaster xs = concat $ intersperse "\n" (map printSlave xs) -instance (PrintSlave (Arg p) v, +instance (PrintSlave (Arg p) v, PrintSlave (BaseType p) v, PrintSlave (Block p) v, PrintSlave (Decl p) v, - PrintSlave (Fortran p) v, + PrintSlave (Fortran p) v, PrintSlave (Implicit p) v, PrintSlave (SubName p) v, PrintSlave (VarName p) v, @@ -88,11 +88,11 @@ instance (PrintSlave (Arg p) v, printMaster (Function _ _ Nothing n a Nothing b) = "function "++(printSlave n)++printSlave a++"\n"++ printSlave b++ "\nend function "++(printSlave n)++"\n" - printMaster (Main _ _ n a b []) = "program "++(printSlave n) ++ + printMaster (Main _ _ n a b []) = "program "++(printSlave n) ++ (if not (isEmptyArg a) then (printSlave a) else ""++"\n") ++ printSlave b ++ "\nend program "++ (printSlave n) ++"\n" - printMaster (Main _ _ n a b ps) = "program "++(printSlave n) ++ + printMaster (Main _ _ n a b ps) = "program "++(printSlave n) ++ (if not (isEmptyArg a) then (printSlave a) else ""++"\n") ++ printSlave b ++ "\ncontains\n" ++ @@ -118,7 +118,7 @@ instance (PrintSlave (Arg p) v, "end block data " ++ (printSlave n)++"\n" printMaster (Prog _ _ p) = printSlave p printMaster (NullProg _ _) = "" - printMaster (IncludeProg _ _ ds Nothing) = printSlave ds + printMaster (IncludeProg _ _ ds Nothing) = printSlave ds printMaster (IncludeProg _ _ ds (Just f)) = printSlave ds ++ "\n" ++ printSlave f instance (PrintSlave (Fortran p) v, PrintSlave (Decl p) v, PrintSlave (Implicit p) v, PPVersion v) => @@ -127,22 +127,22 @@ instance (PrintSlave (Fortran p) v, PrintSlave (Decl p) v, PrintSlave (Implicit instance (PrintSlave (Expr p) v) => PrintMaster (DataForm p) v where - printMaster (Data _ ds) = "data "++(concat (intersperse "\n" (map show_data ds))) + printMaster (Data _ ds) = "data "++(concat (intersperse "\n" (map show_data ds))) -instance (Indentor (Decl p), +instance (Indentor (Decl p), PrintSlave (Arg p) v, PrintSlave (ArgList p) v, PrintSlave (Attr p) v, PrintSlave (BinOp p) v, PrintSlave (Decl p) v, PrintSlave (DataForm p) v, - PrintSlave (Expr p) v, - PrintSlave (GSpec p) v, + PrintSlave (Expr p) v, + PrintSlave (GSpec p) v, PrintSlave (Implicit p) v, - PrintSlave (InterfaceSpec p) v, + PrintSlave (InterfaceSpec p) v, PrintSlave (MeasureUnitSpec p) v, PrintSlave (SubName p) v, - PrintSlave (UnaryOp p) v, + PrintSlave (UnaryOp p) v, PrintSlave (VarName p) v, PrintSlave (Type p) v, PPVersion v) => PrintMaster (Decl p) v where @@ -155,7 +155,7 @@ instance (Indentor (Decl p), printMaster (AccessStmt _ p gs) = ind 1++printSlave p ++ " :: " ++ (concat . intersperse ", " . map printSlave) gs++"\n" printMaster (ExternalStmt _ xs) = ind 1++"external :: " ++ (concat (intersperse "," xs)) ++ "\n" printMaster (Interface _ (Just g) is) = ind 1 ++ "interface " ++ printSlave g ++ printMasterInterfaceSpecs is ++ ind 1 ++ "end interface" ++ printSlave g ++ "\n" - printMaster (Common _ _ name exps) = ind 1++"common " ++ (case name of + printMaster (Common _ _ name exps) = ind 1++"common " ++ (case name of Just n -> "/" ++ n ++ "/ " Nothing -> "") ++ (concat (intersperse "," (map printMaster exps))) ++ "\n" printMaster (Interface _ Nothing is) = ind 1 ++ "interface " ++ printMasterInterfaceSpecs is ++ ind 1 ++ "end interface\n" @@ -164,7 +164,7 @@ instance (Indentor (Decl p), printMaster (Include _ i) = "include "++printSlave i printMaster (DSeq _ d d') = printSlave d++printSlave d' printMaster (NullDecl _ _) = "" - + printMasterInterfaceSpecs xs = concat $ intersperse "\n" (map printMaster xs) show_namelist ((x,xs):[]) = "/" ++ printSlave x ++ "/" ++ (concat (intersperse ", " (map printSlave xs))) @@ -178,8 +178,8 @@ showDV (v,e,Just n) = (printMaster v) ++ "*" ++ show n ++ " = "++(p showDU (name,spec) = printMaster name++" = "++printMaster spec -instance (PrintSlave (ArgList p) v, - PrintSlave (BinOp p) v, +instance (PrintSlave (ArgList p) v, + PrintSlave (BinOp p) v, PrintSlave (UnaryOp p) v, PrintSlave (BaseType p) v, PrintSlave (Expr p) v, @@ -200,8 +200,8 @@ instance (PrintSlave (ArgList p) v, printMaster (ArrayT _ rs bt as e e') = printSlave bt++" (len="++printSlave e'++"kind="++printSlave e++")"++" , dimension ("++showRanges rs++")"++printMasterList as -instance (PrintSlave (ArgList p) v, PrintSlave (BinOp p) v, PrintSlave (Expr p) v, PrintSlave (UnaryOp p) v, - PrintSlave (VarName p) v, +instance (PrintSlave (ArgList p) v, PrintSlave (BinOp p) v, PrintSlave (Expr p) v, PrintSlave (UnaryOp p) v, + PrintSlave (VarName p) v, PrintSlave (MeasureUnitSpec p) v, PPVersion v) => PrintMaster (Attr p) v where --new printMaster (Allocatable _) = "allocatable " printMaster (Parameter _) = "parameter " @@ -258,7 +258,7 @@ instance (PrintSlave (SubName p) v, PPVersion v) => PrintMaster (BaseType p) v w printMaster (SomeType _) = error "sometype not valid in output source file" -- Printing statements and expressions --- +-- instance (PrintSlave (ArgList p) v, PrintSlave (BinOp p) v, PrintSlave (Expr p) v, @@ -290,13 +290,13 @@ instance (PrintIndMaster (Fortran p) v, PPVersion v) => PrintMaster (Fortran p) instance (PrintSlave (ArgName p) v, PPVersion v) => PrintMaster (Arg p) v where printMaster (Arg _ vs _) = "("++ printSlave vs ++")" - + instance (PrintSlave (Expr p) v, PPVersion v) => PrintMaster (ArgList p) v where printMaster (ArgList _ es) = "("++printSlave es++")" -- asTuple printSlave es - + instance PPVersion v => PrintMaster (BinOp p) v where printMaster (Plus _) ="+" - printMaster (Minus _) ="-" + printMaster (Minus _) ="-" printMaster (Mul _) ="*" printMaster (Div _) ="/" printMaster (Or _) =".or." @@ -313,12 +313,12 @@ instance PPVersion v => PrintMaster (BinOp p) v where instance PPVersion v => PrintMaster (UnaryOp p) v where printMaster (UMinus _) = "-" printMaster (Not _) = ".not." - + instance PPVersion v => PrintMaster (VarName p) v where - printMaster (VarName _ v) = v + printMaster (VarName _ v) = v instance (PrintSlave (VarName p) v, PrintSlave (ArgName p) v, PPVersion v) => PrintMaster (ArgName p) v where - printMaster (ArgName _ a) = a + printMaster (ArgName _ a) = a printMaster (ASeq _ (NullArg _) (NullArg _)) = "" printMaster (ASeq _ (NullArg _) a') = printSlave a' printMaster (ASeq _ a (NullArg _)) = printSlave a @@ -332,7 +332,7 @@ instance PPVersion v => PrintMaster (SubName p) v where instance PPVersion v => PrintMaster ( Implicit p) v where printMaster (ImplicitNone _) = " implicit none\n" printMaster (ImplicitNull _) = "" - + instance (PrintSlave (Expr p) v, PPVersion v) => PrintMaster (Spec p) v where printMaster (Access _ s) = "access = " ++ printSlave s printMaster (Action _ s) = "action = "++printSlave s @@ -385,11 +385,16 @@ showForall ((s,e,e',e''):is) = s++"="++printSlave e++":"++printSlave e'++"; "++p showUse :: Uses p -> String showUse (UseNil _) = "" -showUse (Use _ (n, []) us _) = ((ind 1)++"use "++n++"\n") ++ (showUse us) -showUse (Use _ (n, renames) us _) = ((ind 1)++"use "++n++", " ++ +showUse (Uses _ (Use n []) us _) = ((ind 1)++"use "++n++"\n") ++ (showUse us) +showUse (Uses _ (Use n renames) us _) = ((ind 1)++"use "++n++", " ++ (concat $ intersperse ", " (map (\(a, b) -> a ++ " => " ++ b) renames)) ++ "\n") ++ (showUse us) - +showUse (Uses _ (UseOnly n renames) us _) = ((ind 1)++"use "++n++", only: " ++ + (concat $ intersperse ", " (map showOnly renames)) ++ + "\n") ++ (showUse us) + where + showOnly (a, Just b) = a ++ " => " ++ b + showOnly (a, Nothing) = a isEmptyArg (Arg _ as _) = and (isEmptyArgName as) isEmptyArgName (ASeq _ a a') = isEmptyArgName a ++ isEmptyArgName a' @@ -408,7 +413,7 @@ opPrec (And _) = 1 opPrec (RelEQ _) = 2 opPrec (RelNE _) = 2 opPrec (RelLT _) = 2 -opPrec (RelLE _) = 2 +opPrec (RelLE _) = 2 opPrec (RelGT _) = 2 opPrec (RelGE _) = 2 opPrec (Concat _) = 3 @@ -425,18 +430,18 @@ class Indentor t where instance Indentor (p ()) where indR t i = ind i -instance (Indentor (Fortran p), +instance (Indentor (Fortran p), PrintSlave (VarName p) v, PrintSlave (Expr p) v, PrintSlave (UnaryOp p) v, - PrintSlave (BinOp p) v, + PrintSlave (BinOp p) v, PrintSlave (ArgList p) v, PrintIndSlave (Fortran p) v, - PrintSlave (DataForm p) v, + PrintSlave (DataForm p) v, PrintSlave (Fortran p) v, PrintSlave (Spec p) v, PPVersion v) => PrintIndMaster (Fortran p) v where printIndMaster i t@(Assg _ _ v e) = (indR t i)++printSlave v++" = "++printSlave e - printIndMaster i t@(DoWhile _ _ e f) = (indR t i)++"do while (" ++ printSlave e ++ ")\n" ++ + printIndMaster i t@(DoWhile _ _ e f) = (indR t i)++"do while (" ++ printSlave e ++ ")\n" ++ printIndSlave (i+1) f ++ "\n" ++ (indR t i) ++ "end do" printIndMaster i t@(For _ _ (VarName _ "") e e' e'' f) = (indR t i)++"do \n"++ (printIndSlave (i+1) f)++"\n"++(indR t i)++"end do" @@ -509,7 +514,7 @@ showNQ = filter ('"'/=) . show -- Indenting -ind = indent 3 +ind = indent 3 indent i l = take (i*l) (repeat ' ') @@ -527,13 +532,13 @@ asDefs n = printList ["\n"++n,"\n"++n,"\n"] asParagraphs = printList ["\n","\n\n","\n"] -- Auxiliary functions --- +-- optTuple :: (?variant :: v, PPVersion v, PrintSlave (UnaryOp p) v, PrintMaster (Expr p) v) => [Expr p] -> String optTuple [] = "" optTuple xs = asTuple printMaster xs -- *optTuple xs = "" -- indent and showInd enable indented printing --- +-- showUnits :: (PPVersion v, ?variant :: v, PrintMaster (Fraction p) v) => [(MeasureUnit, Fraction p)] -> String showUnits units @@ -554,8 +559,8 @@ showBounds (e1,e2) = printMaster e1++":"++printMaster e2 showRanges :: (PPVersion v, ?variant :: v, PrintMaster (Expr p) v) => [(Expr p, Expr p)] -> String showRanges = asSeq showBounds -showPartRefList :: (PPVersion v, ?variant :: v, PrintSlave (VarName p) v, +showPartRefList :: (PPVersion v, ?variant :: v, PrintSlave (VarName p) v, PrintSlave (UnaryOp p) v, PrintMaster (Expr p) v) => [(VarName p,[Expr p])] -> String showPartRefList [] = "" -showPartRefList ((v,es):[]) = printSlave v ++ optTuple es +showPartRefList ((v,es):[]) = printSlave v ++ optTuple es showPartRefList ((v,es):xs) = printSlave v ++ optTuple es ++ "%" ++ showPartRefList xs From 67dd49942ace729447dddaed8e13bbc82c4497ae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=CF=88=EF=BC=88=E3=83=97=E3=82=B5=E3=82=A4=EF=BC=89?= Date: Sat, 28 Nov 2015 00:16:53 +0900 Subject: [PATCH 14/20] you don't need ignore leading white, because there is already a rule to ignore them. --- src/Language/Fortran/Lexer.x | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Language/Fortran/Lexer.x b/src/Language/Fortran/Lexer.x index eea5e9a..ee540bf 100644 --- a/src/Language/Fortran/Lexer.x +++ b/src/Language/Fortran/Lexer.x @@ -112,9 +112,10 @@ tokens :- -- "&" ; -- ignore & anywhere @continuation_line_alt { \s -> ContLineAlt } \n "!".* \n $white*"&" { \s -> ContLineWithComment } - $white*"&"$white*\n { \s -> ContLine } -- ignore & and spaces followed by '\n' (continuation line) - ($white # \r # \n)*"&" { \s -> ContLineNoNewLine } - "!".*\n ; + "&"$white*\n $white*"!".* \n { \s -> ContLineWithComment } + "&"$white*\n { \s -> ContLine } -- ignore & and spaces followed by '\n' (continuation line) + ($white # \r # \n)*"&" { \s -> ContLineNoNewLine } + "!".*$ ; "%" { \s -> Percent } "{" { \s -> LBrace } "}" { \s -> RBrace } From 1a28689b7709a29835032a6835c1ec0be1bf3728 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?=CF=88=EF=BC=88=E3=83=97=E3=82=B5=E3=82=A4=EF=BC=89?= Date: Sun, 29 Nov 2015 09:33:34 +0900 Subject: [PATCH 15/20] remove leading space --- src/Language/Fortran/Lexer.x | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/Language/Fortran/Lexer.x b/src/Language/Fortran/Lexer.x index ee540bf..7a3c718 100644 --- a/src/Language/Fortran/Lexer.x +++ b/src/Language/Fortran/Lexer.x @@ -12,6 +12,7 @@ import Data.Char import Language.Fortran import Language.Haskell.ParseMonad import Debug.Trace +import Control.Monad (replicateM_) } @@ -110,11 +111,10 @@ tokens :- "$" { \s -> Dollar } "NULL()" { \s -> Key "null" } -- "&" ; -- ignore & anywhere - @continuation_line_alt { \s -> ContLineAlt } - \n "!".* \n $white*"&" { \s -> ContLineWithComment } - "&"$white*\n $white*"!".* \n { \s -> ContLineWithComment } - "&"$white*\n { \s -> ContLine } -- ignore & and spaces followed by '\n' (continuation line) - ($white # \r # \n)*"&" { \s -> ContLineNoNewLine } + \n "!".* \n $white*"&" { \s -> ContLineWithComment 2 } + "&" $white* ("!" .*)? \n ($white*"!".* \n)+ { \s -> ContLineWithComment (length (filter (== '\n') s)) } + "&" $white* ("!" .*)? \n { \s -> ContLine } -- ignore & and spaces followed by '\n' (continuation line) + "&" { \s -> ContLineNoNewLine } "!".*$ ; "%" { \s -> Percent } "{" { \s -> LBrace } @@ -166,7 +166,7 @@ data Token = Key String | LitConst Char String | OpPower | OpMul | OpDiv | OpAdd | LParen | RParen | LArrCon | RArrCon | OpEquals | RealConst String | StopParamStart | SingleQuote | StrConst String | Period | Colon | ColonColon | SemiColon | DataEditDest String | Arrow | MArrow | TrueConst | FalseConst | Dollar - | Hash | LBrace | RBrace | NewLine | TokEOF | Text String | ContLine | ContLineAlt | ContLineWithComment | ContLineNoNewLine + | Hash | LBrace | RBrace | NewLine | TokEOF | Text String | ContLine | ContLineAlt | ContLineWithComment Int | ContLineNoNewLine deriving (Eq,Show) keywords :: [String] @@ -221,11 +221,12 @@ lexer' = do s <- getInput AlexToken (_,b,s') len act -> do let tok = act (take len s) -- turn on for useful debugging info on lexing -- (show (tok, (take 20 s), len) ++ "\n") `trace` return () + (show (tok, (take 20 s), len) ++ "\n") `trace` return () case tok of NewLine -> lexNewline >> (return tok) ContLine -> (discard (len - 1)) >> lexNewline >> lexer' ContLineNoNewLine -> (discard len) >> lexer' ContLineAlt -> lexNewline >> (discard (len - 1)) >> lexer' - ContLineWithComment -> lexNewline >> lexNewline >> (discard (len - 2)) >> lexer' + ContLineWithComment lines -> replicateM_ lines lexNewline >> (discard (len - lines)) >> lexer' _ -> (discard len) >> (return tok) } From da6c2b544fe812b1391ad4bc75cbfe21790e37cf Mon Sep 17 00:00:00 2001 From: dominic Date: Wed, 27 Jan 2016 12:48:19 +0000 Subject: [PATCH 16/20] wider format string acceptance --- src/Language/Fortran/Parser.y | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Language/Fortran/Parser.y b/src/Language/Fortran/Parser.y index 11f7dd4..d43c9f8 100644 --- a/src/Language/Fortran/Parser.y +++ b/src/Language/Fortran/Parser.y @@ -1622,7 +1622,7 @@ print_stmt format :: { Expr A0 } format : expr { $1 } --- | literal_constant { (Con $1) } -- label +| STR {% getSrcSpanNull >>= (\s -> return $ (Con () s $1)) } -- string literal | '*' {% getSrcSpanNull >>= (\s -> return $ Var () s [(VarName () "*",[])]) } output_item_list :: { [Expr A0] } @@ -1693,15 +1693,15 @@ floating_spec : DATA_DESC {% getSrcSpanNull >>= (\s -> return $ Floating () io_control_spec_id :: { Spec A0 } : variable { NoSpec () $1 } --| UNIT '=' format { Unit () $3 } ---| ID '=' format {% case (map (toLower) $1) of --- "fmt" -> return (FMT () $3) --- "rec" -> return (Rec () $3) --- "advance" -> return (Advance () $3) --- "nml" -> return (NML () $3) --- "iostat" -> return (IOStat () $3) --- "size" -> return (Size () $3) --- "eor" -> return (Eor () $3) --- s -> parseError ("incorrect name in spec list: " ++ s) } +| ID '=' format {% case (map (toLower) $1) of + "fmt" -> return (FMT () $3) + "rec" -> return (Rec () $3) + "advance" -> return (Advance () $3) + "nml" -> return (NML () $3) + "iostat" -> return (IOStat () $3) + "size" -> return (Size () $3) + "eor" -> return (Eor () $3) + s -> parseError ("incorrect name in spec list: " ++ s) } -- | namelist_group_name { NoSpec $1 } From 2bf84971091e19b63c574e3bd5e490ac53d6992c Mon Sep 17 00:00:00 2001 From: dominic Date: Thu, 18 Feb 2016 17:00:09 +0000 Subject: [PATCH 17/20] removed the debug info --- src/Language/Fortran/Lexer.x | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/Fortran/Lexer.x b/src/Language/Fortran/Lexer.x index 7a3c718..231ff68 100644 --- a/src/Language/Fortran/Lexer.x +++ b/src/Language/Fortran/Lexer.x @@ -221,7 +221,7 @@ lexer' = do s <- getInput AlexToken (_,b,s') len act -> do let tok = act (take len s) -- turn on for useful debugging info on lexing -- (show (tok, (take 20 s), len) ++ "\n") `trace` return () - (show (tok, (take 20 s), len) ++ "\n") `trace` return () + return () case tok of NewLine -> lexNewline >> (return tok) ContLine -> (discard (len - 1)) >> lexNewline >> lexer' From 64347a23c9b2bc52624d62159981fbc2449ba489 Mon Sep 17 00:00:00 2001 From: Andrew Rice Date: Sun, 6 Mar 2016 13:37:58 +0000 Subject: [PATCH 18/20] Stack support. You should be able to build this with "stack build" now. --- stack.yaml | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 stack.yaml diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..69978c4 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,15 @@ +resolver: lts-5.5 + +# Local packages, usually specified by relative directory name +packages: +- '.' + +# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: {} + +# Extra package databases containing global packages +extra-package-dbs: [] + From a914581d2234f3a52c29606f266bb1219f0309b1 Mon Sep 17 00:00:00 2001 From: dominic Date: Thu, 10 Mar 2016 13:12:28 +0000 Subject: [PATCH 19/20] version number change; towards new kind of labels --- language-fortran.cabal | 2 +- src/Language/Fortran/Parser.y | 14 ++++++++++---- 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/language-fortran.cabal b/language-fortran.cabal index 9e85b0c..31c225d 100644 --- a/language-fortran.cabal +++ b/language-fortran.cabal @@ -1,5 +1,5 @@ name: language-fortran -version: 0.4 +version: 0.5 synopsis: Fortran lexer and parser, language support, and extensions. description: Lexer and parser for Fortran roughly supporting standards from diff --git a/src/Language/Fortran/Parser.y b/src/Language/Fortran/Parser.y index 505fc6b..7ab53e9 100644 --- a/src/Language/Fortran/Parser.y +++ b/src/Language/Fortran/Parser.y @@ -1151,8 +1151,8 @@ do_block_cont : | line newline do_block_cont { let (fs, n) = $3 in (FSeq () (spanTrans $1 fs) $1 fs, n) } line :: { Fortran A0 } -line : num executable_constructP {% getSrcSpanNull >>= (\s -> return $ Label () s $1 $2 ) } - | executable_constructP { $1 } +line : executable_constructP { $1 } + | label executable_constructP {% getSrcSpanNull >>= (\s -> return $ Label () s $1 $2 ) } end_do :: { } end_do @@ -1687,7 +1687,7 @@ io_control_spec | '*' {% getSrcSpanNull >>= (\s -> return $ [NoSpec () (Var () s [(VarName () "*", [])])]) } | STR { [StringLit () $1] } | STR '/' { [StringLit () $1, Delimiter ()] } -| END '=' label { [End () $3] } +| END '=' labelExpr { [End () $3] } | io_control_spec_id { [$1] } | num {% getSrcSpanNull >>= (\s -> return $ [Number () (Con () s $1)]) } | floating_spec { [$1] } @@ -1729,9 +1729,15 @@ input_item -- | '*' { (Var [(VarName () "*",[])]) } -- | internal_file_unit { $1 } -label :: { Expr A0 } +label :: { String } label +: LABEL { $1 } +-- | ID ':' { $1 } + +labelExpr :: {Expr A0} +labelExpr : srcloc LABEL {% (getSrcSpan $1) >>= (\s -> return $ Con () s $2) } +-- | srcloc ID {% (getSrcSpan $1) >>= (\s -> return $ Con () s $2) } num :: { String } num From eb390738c7508bab09562635593ac7da1e9417be Mon Sep 17 00:00:00 2001 From: dominic Date: Fri, 18 Mar 2016 20:16:47 +0000 Subject: [PATCH 20/20] correct span information for subroutine and function arguments --- language-fortran.cabal | 2 +- src/Language/Fortran/Parser.y | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/language-fortran.cabal b/language-fortran.cabal index 31c225d..175536a 100644 --- a/language-fortran.cabal +++ b/language-fortran.cabal @@ -1,5 +1,5 @@ name: language-fortran -version: 0.5 +version: 0.5.1 synopsis: Fortran lexer and parser, language support, and extensions. description: Lexer and parser for Fortran roughly supporting standards from diff --git a/src/Language/Fortran/Parser.y b/src/Language/Fortran/Parser.y index 7ab53e9..08d0a09 100644 --- a/src/Language/Fortran/Parser.y +++ b/src/Language/Fortran/Parser.y @@ -869,7 +869,7 @@ prefix args_p :: { Arg A0 } args_p -: '(' dummy_arg_list srcloc ')' { ($2 (spanExtR ($3, $3) 1)) } +: '(' srcloc dummy_arg_list srcloc ')' { $3 ($2, $4) } dummy_arg_list :: { SrcSpan -> Arg A0 } dummy_arg_list