diff --git a/language-fortran.cabal b/language-fortran.cabal index 9ccd6d8..175536a 100644 --- a/language-fortran.cabal +++ b/language-fortran.cabal @@ -1,5 +1,5 @@ name: language-fortran -version: 0.3 +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.hs b/src/Language/Fortran.hs index 8048ba9..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,30 +74,33 @@ 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) | 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)) 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) @@ -107,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 @@ -121,19 +124,20 @@ 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) -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) 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 @@ -315,7 +319,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 @@ -344,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 @@ -357,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 @@ -369,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 @@ -413,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 @@ -434,7 +437,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 @@ -468,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 @@ -481,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 0c57162..231ff68 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_) } @@ -31,7 +32,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 +45,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+ \") @@ -64,7 +65,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 } @@ -109,18 +111,19 @@ tokens :- "$" { \s -> Dollar } "NULL()" { \s -> Key "null" } -- "&" ; -- 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 "!".* \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 } "}" { \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 } @@ -137,13 +140,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 []) @@ -156,36 +159,35 @@ 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 | 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) --- 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", @@ -210,20 +212,21 @@ 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) -- turn on for useful debugging info on lexing -- (show (tok, (take 20 s), len) ++ "\n") `trace` return () + 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) } diff --git a/src/Language/Fortran/Parser.y b/src/Language/Fortran/Parser.y index 6f6e40e..08d0a09 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 } @@ -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" } @@ -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" } @@ -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" } @@ -188,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] } @@ -209,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 } @@ -239,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 @@ -255,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; @@ -286,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 @@ -311,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 @@ -322,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 @@ -360,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 @@ -377,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 } @@ -403,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 @@ -426,14 +432,14 @@ 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)) } | 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)) } @@ -441,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) } @@ -457,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 } @@ -556,7 +562,7 @@ signed_num :: { String } signed_num : '-' num { "-" ++ $2 } | num { $1 } - + -- end array_spec :: { [(Expr A0, Expr A0)] } @@ -570,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 } @@ -578,7 +584,7 @@ include_stmt :: { Decl A0 } specification_expr :: { Expr A0 } specification_expr - : expr { $1 } + : expr { $1 } intent_spec :: { IntentAttr A0 } intent_spec @@ -603,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 ()) [] } @@ -621,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 } @@ -687,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 @@ -696,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] } @@ -704,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)))) } @@ -721,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) } @@ -767,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 @@ -777,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] } @@ -799,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 @@ -818,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)] } @@ -834,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 } @@ -863,14 +869,14 @@ 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 : 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 } @@ -879,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 } @@ -904,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 } @@ -926,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 } @@ -958,63 +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" } -- 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,25 +1146,25 @@ 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) } 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 : 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) @@ -1622,7 +1629,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] } @@ -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,20 +1674,20 @@ 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 ()] } | '*' {% 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] } @@ -1693,15 +1700,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 } @@ -1722,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 @@ -1772,14 +1785,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 +1820,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 +1861,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/PreProcess.hs b/src/Language/Fortran/PreProcess.hs index e272bd5..be94370 100644 --- a/src/Language/Fortran/PreProcess.hs +++ b/src/Language/Fortran/PreProcess.hs @@ -30,12 +30,14 @@ program is transformed to: -} module Language.Fortran.PreProcess ( pre_process + , pre_process_fixed_form , parseExpr ) where import Text.ParserCombinators.Parsec hiding (spaces) import System.Environment +import Debug.Trace num = many1 digit small = lower <|> char '_' @@ -136,9 +138,69 @@ parseExpr file input = (flip setSourceColumn) 1 $ pos pre_parser [] +{- + - Change Fortran77 style C, c, and * comments to ! comments. + -} +processComments :: String -> String +processComments source = unlines $ map changeComment $ lines source + +changeComment :: String -> String +changeComment "" = "" +changeComment original@(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 = parseExpr "" - +pre_process input = parseExpr "" input + +pre_process_fixed_form input = + parseExpr "" + $ processComments + $ processOldContLines input + go filename = do args <- getArgs srcfile <- readFile filename return $ parseExpr filename srcfile diff --git a/src/Language/Fortran/Pretty.hs b/src/Language/Fortran/Pretty.hs index a793e1e..dce5e41 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 -- +-- Pretty.hs - +-- Based on code by Martin Erwig from Parameterized Fortran +-- Fortran pretty printer -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE ExistentialQuantification, FlexibleContexts, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, DeriveDataTypeable, QuasiQuotes, DeriveFunctor, ImplicitParams, OverlappingInstances, ConstraintKinds #-} module Language.Fortran.Pretty where @@ -20,395 +11,390 @@ import Language.Fortran import Debug.Trace import Data.List -data Alt1 = Alt1 -data Alt2 = Alt2 -data Alt3 = Alt3 - -class Alts a -instance Alts Alt1 -instance Alts Alt2 -instance Alts Alt3 - ---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 - -class OutputG t v where - outputG :: (?variant :: v) => t -> String - --- Default alt1 instance -instance (OutputF t Alt1) => OutputG t Alt1 where - outputG = outputF - -instance Alts v => OutputG Char v where - outputG = show - -instance Alts v => OutputG String v where - outputG = id - -instance (Alts v, OutputG a v, OutputG b v) => OutputG (a, b) v where - outputG (a, b) = "(" ++ outputG a ++ ", " ++ outputG b ++ ")" - -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) - -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) - -class OutputIndF t v where - outputIndF :: (?variant :: v) => Int -> t -> String - -class OutputIndG t v where - outputIndG :: (?variant :: v) => Int -> t -> String - -instance (OutputIndF t Alt1) => OutputIndG t Alt1 where - outputIndG = outputIndF - - --- 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 - -showElseIf i (e,f) = (ind i)++"else if ("++outputG e++") then\n"++(ind (i+1))++outputG f++"\n" - -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 ++ +-- | Core pretty-printing primitive +pprint :: PrettyPrintable t => t -> String +pprint = let ?variant = DefaultPP in printMaster + +-- | Define default pretty-print version constructor +data DefaultPP = DefaultPP -- Default behaviour + +-- | The set of all types which can be used to switch between pretty printer versions +class PPVersion a +instance PPVersion DefaultPP + +-- Pretty printable types predicate (aliases the PrintMaster constraint) +type PrettyPrintable t = PrintMaster t DefaultPP + +-- | Master print behaviour +class PrintMaster t v where + printMaster :: (?variant :: v) => t -> String + +-- | Slave print behaviour +class PrintSlave t v where + printSlave :: (?variant :: v) => t -> String + +-- | Slave print-indenting behaviour +class PrintIndSlave t v where + printIndSlave :: (?variant :: v) => Int -> t -> String + +-- | Master print-indenting behaviour +class PrintIndMaster t v where + printIndMaster :: (?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 + +-- | Behaviours that all slaves must have, i.e., for all versions v +instance PPVersion v => PrintSlave String v where + printSlave = id + +-------------------------------------------------------------------------- + +-- | Definition of the master pretty printer which, notably, is defined for all versions 'v'. +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, + 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 - -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 (OutputG (Expr p) v) => OutputF (DataForm p) v where - outputF (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 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 (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 (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, + PrintSlave (Decl p) v, + PrintSlave (DataForm p) v, + PrintSlave (Expr p) v, + PrintSlave (GSpec p) v, + PrintSlave (Implicit 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 ++ 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 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 _ _) = "" - -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 - --- 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 (Character _) = "character" - outputF (Logical _) = "logical" - outputF (DerivedType _ s) = "type ("++outputG s++")" - outputF (SomeType _) = error "sometype not valid in output source file" + Nothing -> "") ++ (concat (intersperse "," (map printMaster exps))) ++ "\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 + +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 (OutputG (Expr p) v, Alts v) => OutputF (ArgList p) v where - outputF (ArgList _ es) = "("++outputG es++")" -- asTuple outputG 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 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 (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 (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 (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 (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 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 (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 (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' @@ -427,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 @@ -440,75 +426,79 @@ opPrec (Power _) = 6 class Indentor t where indR :: t -> Int -> String -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" +-- Default indenting for code straight out of the parser +instance Indentor (p ()) where + indR t i = ind i + +instance (Indentor (Fortran p), + 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 $- @@ -524,7 +514,7 @@ showNQ = filter ('"'/=) . show -- Indenting -ind = indent 3 +ind = indent 3 indent i l = take (i*l) (repeat ' ') @@ -542,35 +532,35 @@ asDefs n = printList ["\n"++n,"\n"++n,"\n"] 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 \ No newline at end of file +showPartRefList ((v,es):[]) = printSlave v ++ optTuple es +showPartRefList ((v,es):xs) = printSlave v ++ optTuple es ++ "%" ++ showPartRefList xs 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: [] +