{
module Language.Fortran.Parser (
    parser
  , include_parser
    -- * Helpers
  , fst3
  , snd3
  , trd3
  , fst4
  , snd4
  , trd4
  , frh4
  )
  where

import Language.Fortran
import Language.Fortran.PreProcess

import qualified Language.Haskell.Syntax as LH (SrcLoc(..))
import Language.Haskell.ParseMonad
import Language.Fortran.Lexer
import Data.Char (toLower)
import Debug.Trace

}

%name parser executable_program
%name include_parser include_program
%tokentype { Token }

%monad { P } { >>= } { return }
%lexer { lexer } { TokEOF }

%token
 '=>'			{ Arrow }
 '**'			{ OpPower }
 '//' 			{ OpConcat }
 '=='		        { OpEQ }
 '/='       		{ OpNE }
 '<='		        { OpLE }
 '>='		        { OpGE }
 '.NOT.'		{ OpNOT }
 '.AND.'		{ OpAND }
 '.OR.'		        { OpOR }
 '.TRUE.'		{ TrueConst }
 '.FALSE.'		{ FalseConst }
-- '.EQV.'		{ OpEQV }
-- '.NEGV.' 	       	{ OpNEQV }
 '<'		        { OpLT }
 '>'		        { OpGT }
 '*'		       	{ OpMul }
 '/'		       	{ OpDiv }
 '+'		       	{ OpAdd }
 '-'		       	{ OpSub }
 ','		       	{ Comma }
 '('		       	{ LParen }
 ')'		       	{ RParen }
 '='		       	{ OpEquals }
-- '\''		      	{ SingleQuote }
-- '\"'			{ DoubleQuote }
 '.'		        { Period }
 '::'			{ ColonColon }
 ':'			{ Colon }
 ';'                    { SemiColon }
 '#'                    { Hash }
 '{'                    { LBrace }
 '}'                    { RBrace }
 '(/'                   { LArrCon }
 '/)'                   { RArrCon }
 DATA_DESC              { DataEditDest $$ }
--'b'                    { LitMark $$ }
--'B'                    { LitMark $$ }
--'z'                    { LitMark $$ }
--'Z'                    { LitMark $$ }
--'o'                    { LitMark $$ }
--'O'                    { LitMark $$ }
-- OBSOLETE '!'         { Bang }
 '%'			{ Percent }
 '$'			{ Dollar }
 -- OBSOLETE '!{'	{ StopParamStart }
'\n'                    { NewLine }
 ALLOCATE 		{ Key "allocate" }
 ALLOCATABLE 		{ Key "allocatable" }
 ASSIGN 		{ Key "Assign" }
 ASSIGNMENT 		{ Key "assignment" }
-- AUTOMATIC 		{ Key "automatic" }
 BACKSPACE 		{ Key "backspace" }
 BLOCK 			{ Key "block" }
 CALL 			{ Key "call" }
-- CASE 		{ Key "case" }
 CHARACTER 		{ Key "character" }
 CLOSE 			{ Key "close" }
 COMMON 		{ Key "common" }
 COMPLEX 		{ Key "complex" }
 CONTAINS 		{ Key "contains" }
 CONTINUE 		{ Key "continue" }
 CYCLE 			{ Key "cycle" }
 DATA 			{ Key "data" }
 DEALLOCATE 		{ Key "deallocate" }
-- DEFAULT 		{ Key "default" }
 DIMENSION 		{ Key "dimension" }
 DO 			{ Key "do" }
 DOUBLE_PRECISION { Key "double precision" }
 ELEMENTAL 		{ Key "elemental" }
 ELSE 			{ Key "else" }
 ELSEIF 		{ Key "elseif" }
 ELSEWHERE 		{ Key "elsewhere" }
 END 			{ Key "end" }
 ENDIF			{ Key "endif" }
 ENDDO			{ Key "enddo" }
 ENDFILE                { Key "endfile" }
-- ENTRY 		{ Key "entry" }
 EQUIVALENCE 		{ Key "equivalence" }
 EXIT 			{ Key "exit" }
 EXTERNAL 		{ Key "external" }
 FORALL 		{ Key "forall" }
 FOREACH		{ Key "foreach" }
 FORMAT 		{ Key "format" }
 FUNCTION 		{ Key "function" }
 GOTO 			{ Key "goto" }
 IOLENGTH               { Key "iolength" }
 IF 			{ Key "if" }
 IMPLICIT 		{ Key "implicit" }
 IN 			{ Key "in" }
 INCLUDE		{ Key "include" }
 INOUT 			{ Key "inout" }
 INTEGER 		{ Key "integer" }
 INTENT 		{ Key "intent" }
 INTERFACE 		{ Key "interface" }
 INTRINSIC 		{ Key "intrinsic" }
 INQUIRE 		{ Key "inquire" }
 KIND 			{ Key "kind" }
 LEN 			{ Key "len" }
 LOGICAL 		{ Key "logical" }
 MODULE 		{ Key "module" }
 NAMELIST 		{ Key "namelist" }
 NONE 			{ Key "none" }
 NULLIFY 		{ Key "nullify" }
 NULL 			{ Key "null" }
 ONLY 		{ Key "only" }
 OPEN 			{ Key "open" }
 OPERATOR 		{ Key "operator" }
 OPTIONAL 		{ Key "optional" }
 OUT 			{ Key "out" }
 PARAMETER 		{ Key "parameter" }
 PAUSE 		        { Key "pause" }
 POINTER 		{ Key "pointer" }
 PRINT 			{ Key "print" }
 PRIVATE 		{ Key "private" }
 PROCEDURE 		{ Key "procedure" }
 PROGRAM 		{ Key "program" }
 PURE 			{ Key "pure" }
 PUBLIC 		{ Key "public" }
 REAL 			{ Key "real" }
 READ 			{ Key "read" }
 RECURSIVE 		{ Key "recursive" }
 RESULT 		{ Key "result" }
 RETURN 		{ Key "return" }
 REWIND 		{ Key "rewind" }
 SAVE 			{ Key "save" }
-- SELECT 		{ Key "select" }
 SEQUENCE 		{ Key "sequence" }
-- SIZE 		{ Key "size" }
 SOMETYPE               { Key "sometype" }
 SQRT			{ Key "sqrt" }
 STAT 			{ Key "stat" }
 STOP			{ Key "stop" }
 STR                    { StrConst $$ }
 ZLIT                   { LitConst 'z' $$ }
 SUBROUTINE 		{ Key "subroutine" }
 TARGET 		{ Key "target" }
-- TO 			{ Key "to" }
 THEN 			{ Key "then" }
 TYPE 			{ Key "type" }
-- UNFORMATED 		{ Key "unformatted" }
 UNIT                   { Key "unit" } -- units-of-measure extension
 '1'                    { Num "1" }    -- units-of-measure extension
 USE 			{ Key "use" }
 VOLATILE 		{ Key "volatile" }
 WHILE 			{ Key "while" }
 WHERE 			{ Key "where" }
 WRITE 			{ Key "write" }
 ID                     { ID $$ }
 NUM                    { Num $$ }
 LABEL                  { Num $$ }
 TEXT                   { Text $$ }
%%

include_program :: { Program A0 }
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] }
  | {- empty -}                                   { [] }

program_unit :: { ProgUnit A0 }
program_unit
  : main_program                                  { $1 }
  | external_subprogram                           { $1 }
  | module                                        { $1 }
  | block_data                                    { $1 }

plist :: { [String] }
plist
  : plist ',' id2                                 { $1++[$3] }
  | id2                                           { [$1] }

vlist :: { [Expr A0] }
vlist
  : variable ',' vlist                            { $1:$3 }
  | variable                                      { [$1] }

newline :: {}
newline : '\n' newline0 {}
-- | ';' newline0 {}

newline0 :: {}
newline0 : newline  {}
        | {- empty -} {}

main_program :: { ProgUnit A0 }
main_program
  : srcloc program_stmt srcloc use_stmt_list implicit_part srcloc specification_part_top execution_part module_subprogram_part end_program_stmt newline0
                {% do { s <- getSrcSpan $1;
		        s' <- getSrcSpan $6;
		        name <- cmpNames (fst $2) $10 "program";
		        return (Main () s name (snd $2) (Block () (UseBlock $4 $3) $5 s' $7 $8) $9); } }



program_stmt :: { (SubName A0, Arg A0) }
program_stmt
  : PROGRAM subname args_p newline   { ($2, $3) }
  | PROGRAM subname srcloc newline   { ($2, (Arg () (NullArg ())) ($3, $3)) }

end_program_stmt :: { String }
end_program_stmt
  : END PROGRAM id2   { $3 }
  | END PROGRAM       { "" }
  | END               { "" }

implicit_part :: { Implicit A0 }
implicit_part
  : IMPLICIT NONE newline   { ImplicitNone () }
  | {- empty -}             { ImplicitNull () }

external_subprogram :: { ProgUnit A0}
external_subprogram
  : function_subprogram           { $1 }
  | subroutine_subprogram         { $1 }

subroutine_subprogram :: { ProgUnit A0 }
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;
          name <- cmpNames (fst3 $2) $9 "subroutine";
          return (Sub () s (trd3 $2) name (snd3 $2) (Block () (UseBlock $4 $3) $5 s' $7 $8)); } }

end_subroutine_stmt :: { String }
end_subroutine_stmt
  : END SUBROUTINE id2          { $3 }
  | END SUBROUTINE              { "" }
  | END                         { "" }

end_function_stmt :: { String }
end_function_stmt
  : END FUNCTION id2            { $3 }
  | END FUNCTION                { "" }
  | END                         { "" }

function_subprogram :: { ProgUnit A0 }
function_subprogram
: srcloc function_stmt srcloc use_stmt_list implicit_part srcloc specification_part_top execution_part end_function_stmt newline0  {% do { s <- getSrcSpan $1;
                       s' <- getSrcSpan $6;
                       name <- cmpNames (fst4 $2) $9 "function";
		       return (Function () s (trd4 $2) name (snd4 $2) (frh4 $2) (Block () (UseBlock $4 $3) $5 s' $7 $8)); } }

block_data :: { ProgUnit A0 }
block_data
  : 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 () }

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
         {%  do { s <- getSrcSpan $1;
                  name <- cmpNames $2 $7  "module";
		  return (Module () s name $3 $4 $5 $6); } }

module_stmt :: { SubName A0 }
module_stmt
  : MODULE subname newline                    { $2 }

end_module_stmt :: { String }
end_module_stmt
  : END MODULE id2                            { $3 }
  | END MODULE                                { "" }
  | END                                       { "" }

module_subprogram_part :: { Program A0 }
module_subprogram_part
  : CONTAINS newline internal_subprogram_list { $3 }
| {- empty -}                                 { [] }

internal_subprogram_list :: { Program A0 }
internal_subprogram_list
  : 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  { Uses () $1 $2 () }
| {- empty -}  	  { UseNil () }

use_stmt :: { Use }
use_stmt
: 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
   : specification_part   { $1 }
   | {- empty -}          {% getSrcSpanNull >>= (\s -> return $ NullDecl () s)}

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
  : declaration_construct_p newline { $1 }

declaration_construct_p :: { Decl A0 }
declaration_construct_p
  : declaration_construct                         { $1 }
  | specification_stmt                            { $1 }
  | derived_type_def                              { $1 }
  | TEXT					  { TextDecl () $1 }

-- Not sure about the ArrayT outputs here, think this may be a bug

declaration_construct :: { Decl A0 }
declaration_construct
  : 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)
					     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 }
  | include_stmt { $1 }


attr_spec_list :: {([(Expr A0, Expr A0)],[Attr A0])}
attr_spec_list
  : attr_spec_list ',' attr_spec                  { (fst $1++fst $3,snd $1++snd $3) }
  | {- empty -}                                   { ([],[]) }

entity_decl_list :: { [(Expr A0, Expr A0, Maybe Int)] }
entity_decl_list
: entity_decl ',' entity_decl_list         { $1:$3 }
| entity_decl                              { [$1] }

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)) }

-- | id2                  {% getSrcSpanNull >>= (\s -> return $ (Var () s [(VarName () $1,[])], NullExpr () s, Nothing)) }


object_name :: { String }
object_name
  : id2                                            { $1 }

type_spec_p :: { (BaseType A0, Expr A0, Expr A0) }
type_spec_p
  : type_spec                                     { (fst3 $1, snd3 $1, trd3 $1) }

type_spec :: { (BaseType A0, Expr A0, Expr A0) }
type_spec
: INTEGER kind_selector                         {% getSrcSpanNull >>= (\s -> return $ (Integer (), $2, NullExpr () s))  }
| INTEGER '*' length_value                      {% getSrcSpanNull >>= (\s -> return $  (Integer (), $3, NullExpr () s)) }
| INTEGER                                       {% getSrcSpanNull >>= (\s -> return $  (Integer (), NullExpr () s, NullExpr () s)) }
| REAL kind_selector                            {% getSrcSpanNull >>= (\s -> return $  (Real (), $2, NullExpr () s)) }
| 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                {% 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                                     {% 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)) }
| LOGICAL                                       {% getSrcSpanNull >>= (\s -> return $  (Logical (), NullExpr () s, NullExpr () s)) }
| 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 ')' ] ')' ]

kind_selector :: { Expr A0 }
  : '(' KIND '=' expr ')'                         { $4 }
  | '(' expr ')'                                  { $2 }

char_selector :: { (Expr A0, Expr A0) }  -- (LEN, KIND)
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) }
| '(' char_len_param_value ',' expr ')'                   {% getSrcSpanNull >>= (\s -> return $   ($2,NullExpr () s)) }
| '(' KIND '=' expr ',' LEN '=' char_len_param_value ')'  { ($8,$4) }
| '(' KIND '=' expr ')'                                   {% getSrcSpanNull >>= (\s -> return $   (NullExpr () s,$4)) }

length_selector :: { Expr A0 }
length_selector
: '(' LEN '=' char_len_param_value ')'                    { $4 }
| '(' char_len_param_value ')'                            { $2 }

char_len_param_value :: { Expr A0 }
char_len_param_value
: specification_expr                                     { $1 }
| srcloc '*'                                             {% getSrcSpan $1 >>= (\s -> return $ Con () s "*") }

length_value :: { Expr A0 }
length_value
: srcloc num                                           {% getSrcSpan $1 >>= (\s -> return $ Con () s $2) }

dim_spec :: { [(Expr A0, Expr A0)] }
dim_spec
  : DIMENSION '(' array_spec ')' { $3 }
  | DIMENSION '(' ')'            { [] }  -- modified by Zhe on 11/14/2004

dim_spec_p :: { [(Expr A0, Expr A0)] }
dim_spec_p
  : DIMENSION array_spec { $2 }

attr_spec_p :: { ([(Expr A0, Expr A0)],[Attr A0]) }
attr_spec_p :
  PARAMETER                                      { ([],[Parameter ()]) }
| access_spec                                    { ([],[$1]) }
| ALLOCATABLE                                    { ([],[Allocatable ()]) }
| EXTERNAL                                       { ([],[External ()]) }
| INTENT '(' intent_spec ')'                     { ([],[Intent () $3]) }
| INTRINSIC                                      { ([],[Intrinsic ()]) }
| OPTIONAL                                       { ([],[Optional ()]) }
| POINTER                                        { ([],[Pointer ()]) }
| SAVE                                           { ([],[Save ()]) }
| TARGET                                         { ([],[Target ()]) }
| UNIT '(' unit_spec ')'                         { ([],[MeasureUnit () $3]) } -- units-of-measure
| VOLATILE                                       { ([],[Volatile ()]) }

attr_spec :: { ([(Expr A0, Expr A0)],[Attr A0]) }
attr_spec
: dim_spec                                       { ([],[Dimension () $1]) }
| PARAMETER                                      { ([],[Parameter ()]) }
| access_spec                                    { ([],[$1]) }
| ALLOCATABLE                                    { ([],[Allocatable ()]) }
| EXTERNAL                                       { ([],[External ()]) }
| INTENT '(' intent_spec ')'                     { ([],[Intent () $3]) }
| INTRINSIC                                      { ([],[Intrinsic ()]) }
| OPTIONAL                                       { ([],[Optional ()]) }
| POINTER                                        { ([],[Pointer ()]) }
| SAVE                                           { ([],[Save ()]) }
| TARGET                                         { ([],[Target ()]) }
| UNIT '(' unit_spec ')'                         { ([],[MeasureUnit () $3]) }
| VOLATILE                                       { ([],[Volatile ()]) }

access_spec :: { Attr A0 }
access_spec
: PUBLIC            { Public () }
| PRIVATE           { Private () }

-- start: units-of-measure extension parsing

unit_stmt :: { Decl A0 }
  : UNIT '::' unit_decl_list  {% getSrcSpanNull >>= (\s -> return $ MeasureUnitDef () s $3) }

unit_decl_list :: { [(MeasureUnit, MeasureUnitSpec A0)] }
unit_decl_list
  : unit_decl ',' unit_decl_list  { $1:$3 }
  | unit_decl                     { [$1] }

unit_decl :: { (MeasureUnit, MeasureUnitSpec A0) }
unit_decl
  : srcloc ID '=' unit_spec  {% getSrcSpan $1 >>= (\s -> return ($2, $4)) }

unit_spec :: { MeasureUnitSpec A0 }
unit_spec
: mult_unit_spec '/' mult_unit_spec { UnitQuotient () $1 $3 }
| mult_unit_spec                    { UnitProduct () $1 }
| {- empty -}                       { UnitNone () }

mult_unit_spec :: { [(MeasureUnit, Fraction A0)] }
mult_unit_spec
: mult_unit_spec power_unit_spec { $1++$2 }
| power_unit_spec                { $1 }

power_unit_spec :: { [(MeasureUnit, Fraction A0)] }
power_unit_spec
: ID '**' power_spec { [($1, $3)] }
| ID                 { [($1, NullFraction ())] }
| '1'                { [] }

power_spec :: { Fraction A0 }
power_spec
: '(' signed_num '/' signed_num ')' { FractionConst () $2 $4 }
| signed_num                        { IntegerConst () $1 }
| '(' power_spec ')'                { $2 }

signed_num :: { String }
signed_num
: '-' num { "-" ++ $2 }
| num     { $1 }

-- end

array_spec :: { [(Expr A0, Expr A0)] }
array_spec
  : explicit_shape_spec_list                      { map expr2array_spec $1 }

explicit_shape_spec_list :: { [Expr A0] }
explicit_shape_spec_list
  : explicit_shape_spec_list ','  explicit_shape_spec {$1++[$3]}
  | explicit_shape_spec                               {[$1]}

explicit_shape_spec :: { Expr A0 }
explicit_shape_spec
  : expr  { $1 }
  | bound { $1 }

include_stmt :: { Decl A0 }
: INCLUDE srcloc STR       {% getSrcSpan $2 >>= (\s -> return $ Include () (Con () s $3)) }

specification_expr :: { Expr A0 }
specification_expr
  : expr { $1 }

intent_spec :: { IntentAttr A0 }
intent_spec
: IN            {  In () }
| OUT           { Out () }
| INOUT         { InOut () }

specification_stmt :: { Decl A0 }
specification_stmt
  : access_stmt            { $1 }
  | attr_stmt              { $1 }
  | unit_stmt              { $1 }
--  | allocatable_stmt       { $1 }
  | common_stmt            { $1 }
| data_stmt              { DataDecl () $1 }
  | equivalence_stmt              { $1 }
--  | dimension_stmt         { $1 }
  | external_stmt          { $1 }
--  | intent_stmt            { $1 }
--  | intrinsic_stmt         { $1 }
  | namelist_stmt            { $1 }
--  | optional_stmt          { $1 }
--  | pointer_stmt           { $1 }
  | save_stmt              { $1 }
--  | target_stmt            { $1 }

save_stmt :: { Decl A0 }
 : SAVE { AccessStmt () (Save ()) [] }

common_stmt :: { Decl A0 }
: srcloc COMMON '/' id2 '/' vlist  {% getSrcSpan $1 >>= (\s -> return $ Common () s (Just $4) $6) }
| srcloc COMMON vlist              {% getSrcSpan $1 >>= (\s -> return $ Common () s Nothing $3) }


interface_block :: { Decl A0 }
interface_block
: interface_stmt newline interface_spec_list newline end_interface_stmt  { Interface () $1 $3 }

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
  : 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
        {% do { name <- cmpNames (fst4 $1) $2 "interface declaration";
	        s <- getSrcSpanNull;
	        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
        {% 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 }

sub_name_list :: { [SubName A0 ] }
sub_name_list
  :  sub_name_list ',' subname  { $1++[$3] }
  |  subname                    { [$1] }

derived_type_def :: { Decl A0 }
derived_type_def
  : srcloc derived_type_stmt private_sequence_stmt component_def_stmt_list end_type_stmt
  {% do { sp <- getSrcSpan $1;
	  name <- cmpNames (fst $2) $5 "derived type name";
          return (DerivedTypeDef () sp name (snd $2) $3 $4);  } }

derived_type_stmt :: { (SubName A0, [Attr A0]) }
derived_type_stmt
  : TYPE ',' access_spec  '::' type_name         { ($5,[$3]) }
  | TYPE                  '::' type_name         { ($3,[]) }
  | TYPE                       type_name         { ($2,[]) }

end_type_stmt :: { String }
end_type_stmt
  : END TYPE       { "" }
  | END TYPE id2   { $3 }


type_name :: { SubName A0 }
type_name
: ID           { SubName () $1 }

private_sequence_stmt :: { [Attr A0] }
private_sequence_stmt
: PRIVATE SEQUENCE     { [Private (), Sequence ()] }
| SEQUENCE PRIVATE     { [Sequence (), Private ()] }
| PRIVATE              { [Private ()] }
| SEQUENCE             { [Sequence ()] }
| {- empty -}          { [] }

component_def_stmt_list :: { [Decl A0 ] }
component_def_stmt_list
  : component_def_stmt_list component_def_stmt     { $1++[$2] }
  | component_def_stmt                             { [$1] }

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)
		     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)))) }

component_attr_spec_list :: {([(Expr A0, Expr A0)],[Attr A0])}
component_attr_spec_list
  : component_attr_spec_list ',' component_attr_spec       { (fst $1++fst $3,snd $1++snd $3) }
  | {- empty -}                                            { ([],[]) }

component_attr_spec :: { ([(Expr A0, Expr A0)],[Attr A0]) }
component_attr_spec
:  POINTER              { ([],[Pointer ()]) }
| 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) [] }

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
  : generic_spec                     { $1 }

generic_spec :: { GSpec A0 }
generic_spec
: 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) }

data_stmt_object_list :: { Expr A0 }
data_stmt_object_list
: data_stmt_object_list ',' data_stmt_object   { ESeq ()  (spanTrans $1 $3) $1 $3 }
  | data_stmt_object			       { $1 }

data_stmt_object :: { Expr A0 }
data_stmt_object
  : variable 			{ $1 }


data_stmt_value_list :: { Expr A0 }
data_stmt_value_list
: data_stmt_value_list ',' data_stmt_value	{ ESeq () (spanTrans $1 $3) $1 $3 }
  | data_stmt_value				{ $1 }

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] }
  | id2                        { [$1] }

id2 :: { String } -- hack len
id2 : ID  { $1 }
    | id_keywords { $1 }

id_keywords :: { String } -- identifiers which became keywords, but can still be used as variables
id_keywords : COMMON { "common" } -- allow common as a subname (can happen)
            | ALLOCATE { "allocate " }
	    | id_keywords_2 { $1 }

id_keywords_2 :: { String }
id_keywords_2 : IN   { "in"   }
              | OUT  { "out"  }
              | LEN  { "len"  }

defined_operator :: { BinOp A0 }
defined_operator
--  : defined_binary_op
--  | defined_unary_op
  : intrinsic_operator { $1 }

intrinsic_operator :: { BinOp A0 }
intrinsic_operator
  : '**'        { Power () }
  | '*'         { Mul () }
  | '+'         { Plus () }
  | '//'        { Concat () }
  | rel_op      { $1  }
--  | '.NOT.'     { Not () }
  | '.AND.'     { And () }
  | '.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)] }
  | '/' constant_p '/' namelist_group_object_list                     { [($2,$4)] }

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 }
| RECURSIVE  {% getSrcSpanNull >>= (\s -> return $ (Recursive (), NullExpr () s, NullExpr () s)) }
| PURE       {% getSrcSpanNull >>= (\s -> return $ (Pure (), NullExpr () s, NullExpr () s)) }
| ELEMENTAL  {% getSrcSpanNull >>= (\s -> return $ (Elemental (), NullExpr () s, NullExpr () s)) }

args_p :: { Arg A0 }
args_p
: '(' 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
: dummy_arg_list2 ',' dummy_arg   { ASeq () $1 $3 }
| dummy_arg                       { $1 }

dummy_arg :: { ArgName A0 }
dummy_arg
: ID                     { ArgName () $1 }
| '*'                    { ArgName () "*" }

assignment_stmt :: { Fortran A0 }
assignment_stmt
: variable '=' expr                                  { Assg () (spanTrans $1 $3) $1 $3 }
| srcloc ID '(' section_subscript_list ')' '=' expr  {% getSrcSpan $1 >>= (\s -> return $ Assg () s (Var () s [(VarName () $2, $4)]) $7) }



-- moved up to assignment_stmt
variable :: { Expr A0 }
variable
 : srcloc scalar_variable_name_list     {% (getSrcSpan $1) >>= (\s -> return $ Var () s $2) }


scalar_variable_name_list :: { [(VarName A0, [Expr A0])] }
scalar_variable_name_list
  : scalar_variable_name_list '%' scalar_variable_name    { $1++[$3] }
  | scalar_variable_name                                  { [$1] }


scalar_variable_name :: { (VarName A0, [Expr A0]) }
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])) }

-- | TYPE                           { (VarName () "type", []) } -- a bit of a hack but 'type' allowed as var name
--                                                              --  but causes REDUCE REDUCE conflicts!

-- bound comes through int_expr
subscript :: { Expr A0 }
subscript
  : int_expr                                      { $1 }
  | bound                                         { $1 }

bound :: { Expr A0 }
bound
: expr ':' expr                       { Bound () (spanTrans $1 $3) $1 $3 }
|  ':'                                {% getSrcSpanNull >>= (\s -> return $ Bound () s (NullExpr () s) (NullExpr () s)) }
| expr ':'                            {% getSrcSpanNull >>= (\s' -> return $ Bound () (spanTrans' $1 s') $1 (NullExpr () s')) }
| srcloc ':' expr                     {% (getSrcSpan $1) >>= (\s@(_, l) -> return $ Bound () s (NullExpr () (l, l)) $3) }

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 }
| srcloc ID '=' expr			{% getSrcSpan $1 >>= (\s -> return $ AssgExpr () s $2 $4) }


expr :: { Expr A0 }
expr
  : level_5_expr                                       { $1 }


level_5_expr :: { Expr A0 }
level_5_expr
  : equiv_operand                                      { $1 }

equiv_operand :: { Expr A0 }
equiv_operand
: equiv_operand '.OR.' or_operand                   { Bin () (spanTrans $1 $3) (Or ()) $1 $3 }
  | or_operand                                      { $1 }

or_operand :: { Expr A0 }
or_operand
: or_operand '.AND.' and_operand                    { Bin () (spanTrans $1 $3) (And ()) $1 $3 }
| and_operand                                       { $1 }


and_operand :: { Expr A0 }
and_operand
: level_4_expr                                       { $1 }

level_4_expr :: { Expr A0 }
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_2_expr                     { Bin () (spanTrans $1 $3) (Concat ()) $1 $3 }
| level_2_expr                                       { $1 }

level_2_expr :: { Expr A0 }
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 '*' 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
: level_1_expr '**' mult_operand                     { Bin () (spanTrans $1 $3) (Power ()) $1 $3 }
| level_1_expr                                       { $1 }

level_1_expr :: { Expr A0 }
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 :
   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
: 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
 : 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
-- | srcloc ':'                       {% getSrcSpan $1 >>= (\s -> return $ Bound () s (NullExpr () s) (NullExpr () s)) }

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) }

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
  : literal_constant                             { $1 }

literal_constant :: { Expr A0 }
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
--: 'z' { $1 }
--| 'Z' { $1 }
--| 'b' { $1 }
--| 'B' { $1 }
--| 'o' { $1 }
--| 'O'  { $1 }

logical_literal_constant :: { Expr A0 }
logical_literal_constant
: srcloc '.TRUE.'                  {% (getSrcSpan $1) >>= (\s -> return $ Con () s  ".TRUE.") }
| srcloc '.FALSE.'                 {% (getSrcSpan $1) >>= (\s -> return $ Con () s ".FALSE.") }

rel_op :: { BinOp A0 }
  : '=='                           { RelEQ () }
  | '/='                           { RelNE () }
  | '<'                            { RelLT () }
  | '<='                           { RelLE () }
  | '>'                            { RelGT () }
  | '>='                           { RelGE () }

int_expr :: { Expr A0 }
int_expr
  : expr                             { $1 }

do_variable :: { VarName A0 }
do_variable
: ID                       { VarName () $1 }

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) }
| 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
                    {% do { (fs, n) <- return $ $7;
			    s       <- getSrcSpan $1;
			    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
                    {% do { (fs, n) <- return $ $6;
			    s       <- getSrcSpan $1;
			    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
                    {% do { (fs, n) <- return $ $6;
			    s       <- getSrcSpan $1;
			    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!
                          } }

nonlabel_do_stmt :: { (VarName A0, Expr A0, Expr A0, Expr A0) }
nonlabel_do_stmt
  : DO loop_control                  { $2 }
  | DO                               {% getSrcSpanNull >>= (\s -> return $ (VarName () "", NullExpr () s, NullExpr () s, NullExpr () s)) }

loop_control :: { (VarName A0, Expr A0, Expr A0, Expr A0) }
loop_control
  : do_variable '=' int_expr ','  int_expr loop_control2  { ($1,$3,$5,$6) }
--  | int_expr comma_int_expr_opt comma_opt WHILE '(' scalar_logical_expr ')'

loop_control2 :: { Expr A0 }
loop_control2
  : ',' int_expr                     { $2 }
| {- empty -}                      {% getSrcSpanNull >>= (\s -> return $ Con () s "1") }

do_block :: { Fortran A0 }
do_block : line newline do_block { FSeq () (spanTrans $1 $3) $1 $3 }
| num end_do  {% getSrcSpanNull >>= (\s -> return $ NullStmt () s) }
| end_do      {% getSrcSpanNull >>= (\s -> return $ NullStmt () s) }

do_block_num :: { (Fortran A0, String) }
do_block_num : line newline do_block_num { let (fs, n) = $3 in (FSeq () (spanTrans $1 fs) $1 fs, n) }
| num end_do  {% getSrcSpanNull >>= (\s -> return $ (NullStmt () s, $1)) }


do_block_cont :: { (Fortran A0, String) }
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 :  executable_constructP  { $1 }
            | label executable_constructP   {% getSrcSpanNull >>= (\s -> return $ Label () s $1 $2  ) }

end_do :: { }
end_do
: END DO {}
| ENDDO  {}

block :: { Fortran A0 }
block
  : executable_construct_list        { $1 }

execution_part :: { Fortran A0 }
execution_part
  : executable_construct_list        { $1 }

executable_construct_list :: { Fortran A0 }
executable_construct_list
: executable_construct newline executable_construct_list { FSeq () (spanTrans $1 $3) $1 $3 }
| executable_construct ';' executable_construct_list { FSeq () (spanTrans $1 $3) $1 $3 }
| executable_construct newline { $1 }
| executable_construct ';' { $1 }


executable_construct :: { Fortran A0 }
executable_construct
:  num executable_constructP     {% (getSrcSpanNull) >>= (\s -> return $ Label () s $1 $2) }
|  executable_constructP     { $1 }

executable_constructP :: { Fortran A0 }
executable_constructP
:   do_construct                                  { $1 }
  | if_construct                                  { $1 }
  | action_stmt                                   { $1 }


equivalence_stmt :: { Decl A0 }
equivalence_stmt
: srcloc EQUIVALENCE '(' vlist ')'              {% getSrcSpan $1 >>= (\s -> return $ Equivalence () s $4) }

action_stmt :: { Fortran A0 }
action_stmt
  : allocate_stmt                                 { $1 }
  | assignment_stmt                                { $1 }
  | backspace_stmt                                { $1 }
  | call_stmt                                     { $1 }
  | close_stmt                                    { $1 }
  | continue_stmt                                 { $1 }
  | cycle_stmt                                    { $1 }
  | srcloc data_stmt                              {% getSrcSpan $1 >>= (\s -> return $ DataStmt () s $2) }
  | deallocate_stmt                               { $1 }
  | endfile_stmt                                  { $1 }
--  | end_function_stmt
--  | end_program_stmt
--  | end_subroutine_stmt
  | exit_stmt                                     { $1 }
  | format_stmt                                   { $1 }
  | forall_stmt                                   { $1 }
  | goto_stmt                                     { $1 }
  | if_stmt                                       { $1 }
  | inquire_stmt                                  { $1 }
  | nullify_stmt                                  { $1 }
  | open_stmt                                     { $1 }
  | pointer_assignment_stmt                       { $1 }
  | print_stmt                                    { $1 }
  | read_stmt                                     { $1 }
  | return_stmt                                   { $1 }
  | pause_stmt                                    { $1 }
  | rewind_stmt                                   { $1 }
  | stop_stmt                                     { $1 }
  | where_stmt                                    { $1 }
  | write_stmt                                    { $1 }
  | srcloc TEXT				          {% getSrcSpan $1 >>= (\s -> return $ TextStmt () s $2) }

pause_stmt :: { Fortran A0 }
pause_stmt : srcloc PAUSE STR {% getSrcSpan $1 >>= (\s -> return $ Pause () s $3) }

format_stmt :: { Fortran A0 }
format_stmt : srcloc FORMAT io_control_spec_list_d {% getSrcSpan $1 >>= (\s -> return $ Format () s $3) }

call_stmt :: { Fortran A0 }
call_stmt
: srcloc CALL call_name '(' actual_arg_spec_list ')' {% getSrcSpan $1 >>= (\s -> return $ Call () s $3 (ArgList () $5)) }
| srcloc CALL call_name '(' ')'                       {% getSrcSpan $1 >>= (\s -> return $ Call () s $3 (ArgList () (NullExpr () ($1, $1)))) }
| srcloc CALL call_name                             {% getSrcSpan $1 >>= (\s -> return $ Call () s $3 (ArgList () (NullExpr () ($1, $1)))) }

call_name :: { Expr A0 }
call_name
: srcloc id2                 {% (getSrcSpan $1) >>= (\s -> return $ Var () s [(VarName () $2,[])]) }

actual_arg_spec_list :: { Expr A0 }
actual_arg_spec_list
: actual_arg_spec_list ',' actual_arg_spec      { ESeq () (spanTrans $1 $3) $1 $3 }
| actual_arg_spec                               { $1 }

actual_arg_spec :: { Expr A0 }
actual_arg_spec
  : srcloc ID '=' actual_arg                   {% getSrcSpan $1 >>= (\s -> return $ AssgExpr () s $2 $4) }
  | actual_arg                                 { $1 }

actual_arg  :: { Expr A0 }
actual_arg
  : expr                                        { $1 }
--  | variable
--  | procedre_name
--  | alt_return_spec

else_if_list :: { [(Expr A0, Fortran A0)]  }
else_if_list
  : else_if_list else_if_then_stmt block   { $1++[($2,$3)] }
  | {- empty -}                            { [] }

else_if_stmt :: { Expr A0 }
else_if_stmt
  : ELSE if_then_stmt             { $2 }

if_then_stmt :: { Expr A0 }
if_then_stmt
  : IF '(' logical_expr ')' THEN newline             { $3 }


else_if_then_stmt :: { Expr A0 }
else_if_then_stmt
  : ELSEIF '(' logical_expr ')' THEN newline         { $3 }
  | ELSE IF '(' logical_expr ')' THEN newline         { $4 }


--if_rest :: { ([(Expr A0,Fortran)],Maybe Fortran) }
--: ELSE if_then_stmt block if_rest     { (($2,$3):(fst $4),snd $4) }
--| ELSE block END IF                   { ([],Just $2) }
--| END IF                              { ([],Nothing) }

if_construct :: { Fortran A0 }
if_construct
:
  -- FORTRAN 77 numerical comparison IFs

  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
             {% getSrcSpan $1 >>= (\s -> return $ If () s $2 $3 [] Nothing) }

| 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
             {% 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)) }

--: if_then_stmt block if_rest				  { (If $1 $2 (fst $3) (snd $3)) }
--: if_then_stmt block else_if_list END IF                { (If $1 $2 $3 Nothing) }
--| if_then_stmt block else_if_list ELSE block END IF     { (If $1 $2 $3 (Just $5)) }
--| 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
--    END IF                                        { (If $1 $2 $3) }

end_if_stmt  :: {}
end_if_stmt  : END IF  { }
             | ENDIF   { }


logical_expr :: { Expr A0 }
logical_expr
  : expr                                          { $1 }

allocate_stmt :: { Fortran A0 }
allocate_stmt
  : srcloc ALLOCATE '(' allocation_list ',' STAT '=' variable ')'
             {% getSrcSpan $1 >>= (\s -> return $ Allocate () s $4 $8) }

  | srcloc ALLOCATE '(' allocation_list ')'
            {% getSrcSpanNull >>= (\e -> getSrcSpan $1 >>= (\s -> return $ Allocate () s $4 (NullExpr () e))) }


allocation_list :: { Expr A0 }
allocation_list
: allocation_list ',' allocation                  { ESeq () (spanTrans $1 $3) $1 $3 }
| allocation                                      { $1 }
| {- empty -}                                     {% getSrcSpanNull >>= (return . (NullExpr ())) }

allocate_object_list :: { [Expr A0] }
allocate_object_list
  : allocate_object_list ',' allocate_object      { $1++[$3] }
  | allocate_object                               { [$1] }

allocate_object :: { Expr A0 }
allocate_object
: srcloc scalar_variable_name_list              {% getSrcSpan $1 >>= (\s -> return $ Var () s $2) }

allocate_shape_spec_list :: { [Expr A0] }
allocate_shape_spec_list
  : allocate_shape_spec_list ',' allocate_shape_spec    { $1++[$3] }
  | allocate_shape_spec                                 { [$1] }

allocate_shape_spec :: { Expr A0 }
allocate_shape_spec
  : expr   { $1 }
  | bound  { $1 }

allocation :: { Expr A0 }
allocation
  : allocation_var_list2                          { $1 }

allocation_var_list2 :: { Expr A0 }
allocation_var_list2
: srcloc allocation_var_list                    {% getSrcSpan $1 >>= (\s -> return $ Var () s $2) }

allocation_var_list :: { [(VarName A0,[Expr A0])] }
allocation_var_list
  : allocation_var_list '%' allocation_var      { $1++[$3]  }
  | allocation_var                              { [$1] }

allocation_var :: { (VarName A0, [Expr A0]) }
allocation_var
: ID '(' allocate_shape_spec_list ')'         { (VarName () $1, $3) }
| ID                                          { (VarName () $1, []) }

backspace_stmt :: { Fortran A0 }
backspace_stmt
: srcloc BACKSPACE expr                       {% getSrcSpan $1 >>= (\s -> return $ Backspace () s [NoSpec () $3]) }
| srcloc BACKSPACE '(' position_spec_list ')' {% getSrcSpan $1 >>= (\s -> return $ Backspace () s $4) }

position_spec_list :: { [Spec A0] }
position_spec_list
  : position_spec_list ',' position_spec          { $1++[$3] }
  | position_spec                                 { [$1] }

position_spec :: { Spec A0 }
position_spec
: expr                                          { NoSpec () $1 }
 | srcloc UNIT '=' expr                         { Unit () $4 } -- units-of-measure
 | srcloc ID '=' expr                           {% case (map (toLower) $2) of
 --                                                    "unit"   -> return (Unit   () $4)
                                                       "iostat" -> return (IOStat () $4)
                                                       s        ->  parseError ("incorrect name in spec list: " ++ s) }

close_stmt :: { Fortran A0 }
close_stmt
: srcloc CLOSE '(' close_spec_list ')'          {% getSrcSpan $1 >>= (\s -> return $ Close () s $4) }

close_spec_list :: { [Spec A0] }
close_spec_list
  : close_spec_list ',' close_spec                { $1++[$3] }
  | close_spec                                    { [$1] }

close_spec :: { Spec A0 }
close_spec
: expr                                          { NoSpec () $1 }
| UNIT '=' expr                                 { Unit () $3 } -- units-of-measure
| ID '=' expr
{% case (map (toLower) $1) of
      "iostat" -> return (IOStat () $3)
      "status" -> return (Status () $3)
      s        -> parseError ("incorrect name in spec list: " ++ s) }

--external_file_unit :: { Expr A0 }
--external_file_unit
--  : expr                                          { $1 }

continue_stmt :: { Fortran A0 }
continue_stmt
: srcloc CONTINUE                               {% getSrcSpan $1 >>= (return . (Continue ())) }

cycle_stmt :: { Fortran A0 }
cycle_stmt
: srcloc CYCLE id2                              {% getSrcSpan $1 >>= (\s -> return $ Cycle () s $3) }
| srcloc CYCLE                                  {% getSrcSpan $1 >>= (\s -> return $ Cycle () s "") }

deallocate_stmt :: { Fortran A0 }
deallocate_stmt
: srcloc DEALLOCATE '(' allocate_object_list ',' STAT '=' variable ')'
        {% getSrcSpan $1 >>= (\s -> return $ Deallocate () s $4 $8) }

| srcloc DEALLOCATE '(' allocate_object_list ')'
        {% getSrcSpan $1 >>= (\s -> return $ Deallocate () s $4 (NullExpr () s)) }

endfile_stmt :: { Fortran A0 }
endfile_stmt
: srcloc ENDFILE expr                                  {% getSrcSpan $1 >>= (\s -> return $ Endfile () s [NoSpec () $3]) }
| srcloc ENDFILE '(' position_spec_list ')'            {% getSrcSpan $1 >>= (\s -> return $ Endfile () s $4) }

exit_stmt :: { Fortran A0 }
exit_stmt
: srcloc EXIT id2                                    {% getSrcSpan $1 >>= (\s -> return $ Exit () s $3) }
| srcloc EXIT                                        {% getSrcSpan $1 >>= (\s -> return $ Exit () s "") }

forall_stmt :: { Fortran A0 }
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
                 {% getSrcSpan $1 >>= (\s -> return $ Forall () s $3 $5) }

forall_stmt_end :: {}
forall_stmt_end
  : END FORALL       {}
 | {- empty -}       {}

forall_header :: { ([(String,Expr A0,Expr A0,Expr A0)],Expr A0) }
forall_header
  : '(' forall_triplet_spec_list ',' expr ')'   { ($2,$4) }
| '(' forall_triplet_spec_list ')'              {% getSrcSpanNull >>= (\s -> return ($2, NullExpr () s)) }

forall_triplet_spec_list :: { [(String,Expr A0,Expr A0,Expr A0)] }
forall_triplet_spec_list
  : forall_triplet_spec_list ',' forall_triplet_spec  { $1++[$3]}
  | forall_triplet_spec                               { [$1] }

forall_triplet_spec :: { (String,Expr A0,Expr A0,Expr A0) }
forall_triplet_spec
  : id2 '=' int_expr ':' int_expr ';' int_expr { ($1,$3,$5,$7) }
| id2 '=' int_expr ':' int_expr              {% getSrcSpanNull >>= (\s -> return ($1,$3,$5,NullExpr () s)) }

forall_assignment_stmt :: { Fortran A0 }
forall_assignment_stmt
: assignment_stmt                               { $1 }
| pointer_assignment_stmt                       { $1 }


forall_assignment_stmt_list :: { Fortran A0 }
forall_assignment_stmt_list
: forall_assignment_stmt newline forall_assignment_stmt_list { FSeq () (spanTrans $1 $3) $1 $3 }
| forall_assignment_stmt newline                             { $1 }


goto_stmt :: { Fortran A0 }
goto_stmt
: srcloc GOTO num                                    {% getSrcSpan $1 >>= (\s -> return $ Goto () s $3) }

if_stmt :: { Fortran A0 }
if_stmt
: srcloc IF '(' logical_expr ')' action_stmt       {% getSrcSpan $1 >>= (\s -> return $ If () s $4 $6 [] Nothing) }

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

        {% getSrcSpan $1 >>= (\s -> return $ Inquire () s [IOLength () $6] $8) }

inquire_spec_list :: { [Spec A0] }
inquire_spec_list
  : inquire_spec_list ',' inquire_spec           { $1++[$3] }
  | inquire_spec                                 { [$1] }

inquire_spec :: { Spec A0 }
inquire_spec
: expr                             { NoSpec () $1 }
| UNIT '=' variable                { Unit () $3 } -- units-of-measure
| READ '=' variable                { Read () $3 }
| WRITE '=' variable               { WriteSp () $3 }
| ID '=' expr                      {% case (map (toLower) $1) of
                                            "file"        -> return (File ()	  $3)
                                            "iostat"      -> return (IOStat ()     $3)
                                            "exist"       -> return (Exist ()      $3)
                                            "opened"      -> return (Opened ()     $3)
                                            "number"      -> return (Number ()     $3)
                                            "named"       -> return (Named ()      $3)
                                            "name"        -> return (Name ()       $3)
                                            "access"      -> return (Access ()     $3)
                                            "sequential"  -> return (Sequential () $3)
                                            "direct"      -> return (Direct ()     $3)
                                            "form"        -> return (Form ()       $3)
                                            "formatted"   -> return (Formatted ()  $3)
                                            "unformatted" -> return (Unformatted () $3)
                                            "recl"        -> return (Recl    ()   $3)
                                            "nextrec"     -> return (NextRec ()   $3)
                                            "blank"       -> return (Blank   ()   $3)
                                            "position"    -> return (Position ()  $3)
                                            "action"      -> return (Action   ()  $3)
                                            "readwrite"   -> return (ReadWrite () $3)
                                            "delim"       -> return (Delim    ()  $3)
                                            "pad"         -> return (Pad     ()   $3)
                                            s             -> parseError ("incorrect name in spec list: " ++ s) }
--io_implied_do
--io_implied_do
--  : '(' io_implied_do_object_list ',' io_implied_do_control ')'
--io_implied_do_object
--io_implied_do_object
--  : input_item
--  | output_item
--io_implied_do_control
--io_implied_do_control
--  : do_variable '=' scalar_int_expr ',' scalar_int_expr ',' scalar_int_expr
--  | do_variable '=' scalar_int_expr ',' scalar_int_expr
--file_name_expr
--file_name_expr
--  : scalar_char_expr



nullify_stmt :: { Fortran A0 }
nullify_stmt
: srcloc NULLIFY '(' pointer_object_list ')'           {% getSrcSpan $1 >>= (\s -> return $ Nullify () s $4) }

pointer_object_list :: { [Expr A0] }
pointer_object_list
  : pointer_object_list ',' pointer_object        { $1++[$3] }
  | pointer_object                                { [$1] }

pointer_object :: { Expr A0 }
pointer_object
  : structure_component                           { $1 }

structure_component :: { Expr A0 }
structure_component
  : variable                                      { $1 }

open_stmt :: { Fortran A0 }
open_stmt
: srcloc OPEN '(' connect_spec_list ')'          {% getSrcSpan $1 >>= (\s -> return $ Open () s $4) }

connect_spec_list :: { [Spec A0] }
connect_spec_list
  : connect_spec_list ',' connect_spec            { $1++[$3] }
  | connect_spec                                  { [$1] }

connect_spec :: { Spec A0 }
connect_spec
: expr                    { NoSpec () $1 }
| UNIT '=' expr           { Unit () $3 }
| ID '=' expr             {% case (map (toLower) $1) of
                                          "iostat"   -> return (IOStat () $3)
                                          "file"     -> return (File () $3)
                                          "status"   -> return (Status () $3)
                                          "access"   -> return (Access () $3)
                                          "form"     -> return (Form () $3)
                                          "recl"     -> return (Recl () $3)
                                          "blank"    -> return (Blank () $3)
                                          "position" -> return (Position () $3)
                                          "action"   -> return (Action () $3)
                                          "delim"    -> return (Delim () $3)
                                          "pad"      -> return (Pad () $3)
                                          s          -> parseError ("incorrect name in spec list: " ++ s) }

file_name_expr :: { Expr A0 }
file_name_expr
  : scalar_char_expr                              { $1 }

scalar_char_expr :: { Expr A0 }
scalar_char_expr
  : expr                                          { $1 }

scalar_int_expr :: { Expr A0 }
scalar_int_expr
  : expr                                          { $1 }

pointer_assignment_stmt :: { Fortran A0 }
pointer_assignment_stmt
: srcloc pointer_object '=>' target                    {% getSrcSpan $1 >>= (\s -> return $ PointerAssg () s $2 $4) }

target :: { Expr A0 }
target
  : expr                                          { $1 }



print_stmt :: { Fortran A0 }
print_stmt
: srcloc PRINT format ',' output_item_list           {% getSrcSpan $1 >>= (\s -> return $  Print () s $3 $5) }
| srcloc PRINT format                                {% getSrcSpan $1 >>= (\s -> return $ Print () s $3 []) }

-- also replaces io_unit
format :: { Expr A0 }
format
: expr                                  { $1 }
| STR                                   {% getSrcSpanNull >>= (\s -> return $ (Con () s $1)) } -- string literal
| '*'                                   {% getSrcSpanNull >>= (\s -> return $ Var () s [(VarName () "*",[])]) }

output_item_list :: { [Expr A0] }
output_item_list
  : output_item_list ','  output_item             { $1++[$3] }
  | output_item                                   { [$1] }

output_item :: { Expr A0 }
output_item
  : expr                                          { $1 }
| '(' actual_arg_spec_list ')'                    { $2 }
--  | io_implied_do                                 { $1 }


read_stmt :: { Fortran A0 }
read_stmt
: srcloc READ '(' io_control_spec_list ')' input_item_list {% getSrcSpan $1 >>= (\s -> return $ ReadS () s $4 $6) }
| srcloc READ io_control_spec ',' input_item_list   {% getSrcSpan $1 >>= (\s -> return $ ReadS () s $3 $5) }
| srcloc READ '(' io_control_spec_list ')'                 {% getSrcSpan $1 >>= (\s -> return $ ReadS () s $4 []) }


io_control_spec_list_d :: { [Spec A0] }
io_control_spec_list_d :
  '(/' ',' io_control_spec_list_d2      { (Delimiter ()):$3 }
| '('      io_control_spec_list_d2      { $2 }

{-

| '(/' ',' io_control_spec_list '/)'     { ((Delimiter ()):$3) ++ [Delimiter ()] }
| '('      io_control_spec_list '/)'     { $2 ++ [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 ',' io_control_spec_list_d2  { $1 ++ $3 }
| '/)'                                         { [Delimiter ()] }
| io_control_spec ')'                          { $1 }
| io_control_spec '/)'                         { $1 ++ [Delimiter ()] }


io_control_spec_list :: { [Spec A0] }
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
: --format                           { [NoSpec () $1] }
  '/'                                { [Delimiter ()] }
| '*'                                {% getSrcSpanNull >>= (\s -> return $ [NoSpec () (Var () s [(VarName () "*", [])])]) }
| STR                                { [StringLit () $1] }
| STR '/'                            { [StringLit () $1, Delimiter ()] }
| END '=' labelExpr                  { [End () $3] }
| io_control_spec_id                 { [$1] }
| num                                {% getSrcSpanNull >>= (\s -> return $ [Number () (Con () s $1)]) }
| floating_spec                      { [$1] }


floating_spec :: { Spec A0 }
floating_spec : DATA_DESC      {% getSrcSpanNull >>= (\s -> return $ Floating () (NullExpr () s) (Con () s $1) ) }
| num DATA_DESC  {% getSrcSpanNull >>= (\s -> return $ Floating () (Con () s $1) (Con () s $2)) }

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) }

--  | namelist_group_name                           { NoSpec $1 }

input_item_list :: { [Expr A0] }
input_item_list
  : input_item_list ',' input_item                { $1++[$3] }
  | input_item                                    { [$1] }

input_item :: { Expr A0 }
input_item
  : variable                                      { $1 }


--  | io_implied_do
--io_unit :: { Expr A0 }
--io_unit
--  : expr                                          { $1 }
--  | '*'                                           { (Var [(VarName  () "*",[])]) }
--  | internal_file_unit                            { $1 }

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
: NUM { $1 }
| '1' { "1" }

--internal_file_unit :: { Expr A0 }
--internal_file_unit
--  : default_char_variable                         { $1 }

--default_char_variable :: { Expr A0 }
--default_char_variable
--  : variable       { $1 }

namelist_group_name :: { Expr A0 }
namelist_group_name
  : variable           { $1 }


return_stmt :: { Fortran A0 }
return_stmt
: srcloc RETURN                   {% getSrcSpan $1 >>= (\s -> return $ Return () s (NullExpr () s)) }
| srcloc RETURN int_expr          {% getSrcSpan $1 >>= (\s -> return $ Return () s $3) }

scalar_default_int_variable :: { Expr A0 }
scalar_default_int_variable
  : variable                                      { $1 }

scalar_default_char_expr :: { Expr A0 }
scalar_default_char_expr
  : expr                                          { $1 }

rewind_stmt :: { Fortran A0 }
rewind_stmt
: srcloc REWIND expr                        {% getSrcSpan $1 >>= (\s -> return $ Rewind () s [NoSpec () $3]) }
| srcloc REWIND '(' position_spec_list ')'  {% getSrcSpan $1 >>= (\s -> return $ Rewind () s $4) }



stop_stmt :: { Fortran A0 }
stop_stmt
: srcloc STOP stop_code                  {% getSrcSpan $1 >>= (\s -> return $ Stop () s $3) }
| srcloc STOP                            {% getSrcSpan $1 >>= (\s -> return $ Stop () s (NullExpr () s)) }

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
newline END WHERE {% getSrcSpan $1 >>= (\s -> return $ Where () s $4 $7 (Just $11)) }

where_assignment_stmt :: { Fortran A0 }
where_assignment_stmt
  : assignment_stmt                              { $1 }
mask_expr :: { Expr A0 }
mask_expr
  : logical_expr                                 { $1 }



write_stmt :: { Fortran A0 }
write_stmt
: WRITE '(' io_control_spec_list ')' output_item_list  {% getSrcSpanNull >>= (\s -> return $ Write () s $3 $5) }
| WRITE '(' io_control_spec_list ')'                   {% getSrcSpanNull >>= (\s -> return $ Write () s $3 []) }

srcloc :: { SrcLoc }  :    {% getSrcLoc' }

{

getSrcLoc' = do (LH.SrcLoc f l c) <- getSrcLoc
                return (SrcLoc f l (c - 1))

-- Initial annotations from parser

-- Type of annotations

type A0 = ()

getSrcSpan :: SrcLoc -> P (SrcLoc, SrcLoc)
getSrcSpan l = do l' <- getSrcLoc'
                  return $ (l, l')

-- 0-length span at current position

getSrcSpanNull :: P (SrcLoc, SrcLoc)
getSrcSpanNull = do l <- getSrcLoc'
                    return $ (l, l)

spanTrans x y = let (l, _) = srcSpan x
		    (_, l') = srcSpan y
                in (l, l')

spanTrans' x (_, l') = let (l, _) = srcSpan x
                       in (l, l')

spanExtendR t x = let (l, l') = srcSpan t
                  in (l, SrcLoc (srcFilename l') (srcLine l') (srcColumn l' + x))

spanExtR (l, l') x = (l, SrcLoc (srcFilename l') (srcLine l') (srcColumn l' + x))

spanExtendL t x = let (l, l') = srcSpan t
                  in (SrcLoc (srcFilename l) (srcLine l) (srcColumn l - x), l')

happyError :: P a
happyError = parseError "syntax error (from parser)"

parseError :: String -> P a
parseError m = do srcloc <- getSrcLoc'
		  fail (srcFilename srcloc ++ ": line " ++ show (srcLine srcloc) ++ " column " ++ show (srcColumn srcloc) ++ ": " ++ m ++ "\n")

tokenFollows s = case alexScan ('\0',[],s) 0 of
                    AlexEOF                 -> "end of file"
                    AlexError  _            -> ""
                    AlexSkip  (_,b,t) len   -> tokenFollows t
	            AlexToken (_,b,t) len _ -> take len s

parse :: String -> Program A0
parse p = case (runParser parser (pre_process p)) of
	    (ParseOk p)       -> p
            (ParseFailed l e) ->  error e

--parse :: String -> [Program]
--parse = clean . parser . fixdecls . scan

parseF :: String -> IO ()
parseF f = do s <- readFile f
              print (parse s)

--scanF :: String -> IO ()
--scanF f = do s <- readFile f
--             print (scan s)

fst3 (a,b,c) = a
snd3 (a,b,c) = b
trd3 (a,b,c) = c

fst4 (a,b,c,d) = a
snd4 (a,b,c,d) = b
trd4 (a,b,c,d) = c
frh4 (a,b,c,d) = d

cmpNames :: SubName A0 -> String -> String -> P (SubName A0)
cmpNames x "" z                        = return x
cmpNames (SubName a x) y z | x==y      = return (SubName a x)
                           | otherwise = parseError (z ++ " name \""++x++"\" does not match \""++y++"\" in end " ++ z ++ " statement\n")
cmpNames s y z                       = parseError (z ++" names do not match\n")

expr2array_spec (Bound _ _ e e') = (e, e') -- possibly a bit dodgy- uses undefined
expr2array_spec e = (NullExpr () (srcSpan e) , e)

}