language-fortran-0.4: src/Language/Fortran/PreProcess.hs
{-|
The following provides a string → string preprocessor for Fortran
programs that deals with label-delimited @do@-@continue@ blocks of
FORTRAN 77 era. With a traditional LR(1) parser, these are not easily
(or not at all) parsable. Consider the valid FORTRAN 77 code:
> do j = 1,5
> do 17 i=1,10
> print *,i
> 17 continue
> end do
Here the \'continue\' acts as an \'end do\' (not as a usual
\'continue\' statement) because it is labelled with the same label
\'17\' as the \'do\' statement which starts the block. Parsing this
requires arbitrary look-ahead (e.g., LR(infinity)) which is provided
by the following parsec parser, but not by the \'happy\' parser
generator.
This pre processor is currently quite heavy handed. It replaces
\'continue\' in the above program with \'end do\'. E.g., the above
program is transformed to:
> do j = 1,5
> do 17 i=1,10
> print *,i
> 17 end do
> end do
-}
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 '_'
idchar = small <|> upper <|> digit
ident = do{ c <- small <|> upper ; cs <- many idchar; return (c:cs) }
spaces = many space
manyTillEnd p end =
scan where scan = (try end) <|> do { x <- p; xs <- scan; return (x:xs) }
pre_parser labels = manyTillEnd anyChar
(try $ if null labels then try (end_or_start_do labels) <|> (eof >> return "")
else end_or_start_do labels)
end_or_start_do labels = (try $ doBlock labels) <|> (end_do labels)
doBlock labels =
do doStr <- string "do" <|> string "DO"
updateState (+1)
sp <- spaces
label <- (try numberedBlock) <|> (do { loop <- loop_control; return (Nothing, loop) })
p <- pre_parser $ (fst label) : labels
return $ doStr ++ sp ++ snd label ++ p
end_do labels = do label' <- optionMaybe (do {space; n <- num; space; return n})
sp <- spaces
lookAhead (end_do_marker <|> continue)
ender <-
case (labels, label') of
([], _) -> do { ender <- end_do_marker; return $ sp ++ ender }
(Nothing:_, _) -> do { ender <- end_do_marker; return $ sp ++ ender }
((Just n):_, Nothing) -> do { ender <- end_do_marker; return $ sp ++ ender }
((Just n):_, Just m) -> if (n==m) then do ender <- end_do_marker <|> continue
return $ " " ++ m ++ " " ++ sp ++ ender
else -- Labels don't match!
-- If the label doesn't appear anywhere in the label stack,
-- then this is allowed (e.g. extra 'continue' points)
if Just m `notElem` labels then
do ender <- end_do_marker <|> continue_non_replace
return $ " " ++ m ++ " " ++ sp ++ ender
else
-- otherwise, we consider the do loops to be not properly bracketted
error $ "Ill formed do blocks, labels do not match: " ++ n ++ " and " ++ m ++
" - with label stack " ++ (show labels)
level <- getState
updateState (\x -> x-1) -- "Level " ++ show level) `trace` (
p <- pre_parser (if labels == [] then [] else tail labels)
return $ ender ++ p
continue_non_replace = string "continue" <|> string "CONTINUE"
continue = do string "continue" <|> string "CONTINUE"
return "end do " -- replaces continue with 'end do', this is the goal!
end_do_marker = do endStr <- string "end" <|> string "END"
sp <- spaces
doStr <- string "do" <|> string "DO"
return $ endStr ++ sp ++ doStr
numberedBlock = do label <- num
space
sp1 <- spaces
comma <- optionMaybe (string ",")
sp2 <- spaces
loop <- loop_control
return $ (Just label, label ++ " " ++ sp1 ++ (maybe "" id comma) ++ sp2 ++ loop)
newline' =
(try $ do { c <- char '\r';
n <- newline;
return [c,n] })
<|> do { n <- newline;
return [n] }
loop_control = do var <- ident
sp1 <- spaces
char '='
sp2 <- spaces
lower <- num <|> ident
sp3 <- spaces
char ','
sp4 <- spaces
upper <- num <|> ident
rest <- manyTillEnd anyChar (try newline')
return $ var ++ sp1 ++ "=" ++ sp2 ++ lower ++ sp3 ++ "," ++ sp4 ++ upper ++ rest
parseExpr :: String -> String -> String
parseExpr file input =
case (runParser p (0::Int) "" input) of
Left err -> fail $ show err
Right x -> x
where
p = do pos <- getPosition
setPosition $ (flip setSourceName) file $
(flip setSourceLine) 1 $
(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 input = parseExpr "" input
pre_process_fixed_form input =
parseExpr ""
$ processComments
$ processOldContLines input
go filename = do args <- getArgs
srcfile <- readFile filename
return $ parseExpr filename srcfile