From 7c2f3fa962c2f456959dea585934562dbad79622 Mon Sep 17 00:00:00 2001 From: qrczak Date: Sat, 13 Jan 2001 19:46:49 +0000 Subject: [PATCH] [project @ 2001-01-13 19:46:49 by qrczak] Generate correct LINE pragmas. --- ghc/utils/hsc2hs/Main.hs | 227 ++++++++++++++++++++++++++++------------------ 1 file changed, 139 insertions(+), 88 deletions(-) diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs index 726e2dd..71abaa3 100644 --- a/ghc/utils/hsc2hs/Main.hs +++ b/ghc/utils/hsc2hs/Main.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.9 2001/01/13 12:11:00 qrczak Exp $ +-- $Id: Main.hs,v 1.10 2001/01/13 19:46:49 qrczak Exp $ -- -- (originally "GlueHsc.hs" by Marcin 'Qrczak' Kowalczyk) -- @@ -12,12 +12,13 @@ -- See the documentation in the Users' Guide for more details. import GetOpt -import System (getProgName, getArgs, ExitCode(..), system, exitWith, exitFailure) -import Directory (removeFile) +import System (getProgName, getArgs, ExitCode(..), system, exitWith, exitFailure) +import Directory (removeFile) import Parsec -import Monad (liftM, liftM2, when) -import Char (ord, intToDigit, isSpace, isAlpha, isAlphaNum, toUpper) -import List (intersperse) +import ParsecError +import Monad (liftM, liftM2, when) +import Char (ord, intToDigit, isSpace, isAlpha, isAlphaNum, toUpper) +import List (intersperse) version :: String version = "hsc2hs-0.64" @@ -77,27 +78,45 @@ processFile flags name = do Right toks -> output flags name toks data Token - = Text String - | Special String String + = Text SourcePos String + | Special SourcePos String String parser :: Parser [Token] parser = many (text <|> special) text :: Parser Token -text = - liftM (Text . concat) $ many1 - ( many1 (satisfy (\ch -> not (isAlpha ch || ch `elem` "\"#'-_{"))) - <|> (do a <- satisfy (\ch -> isAlpha ch || ch == '_') - b <- many (satisfy (\ch -> isAlphaNum ch || ch == '_' || ch == '\'')) - return (a:b)) - <|> (do char '\"'; a <- hsString '\"'; char '\"'; return ("\""++a++"\"")) - <|> (do try (string "##"); return "#") - <|> (do char '\''; a <- hsString '\''; char '\''; return ("\'"++a++"\'")) - <|> (do try (string "--"); a <- many (satisfy (/= '\n')); return ("--"++a)) - <|> string "-" - <|> (do try (string "{-"); a <- hsComment; return ("{-"++a)) - <|> string "{" - "Haskell source") +text = do + pos <- getPosition + liftM (Text pos . concat) $ many1 + ( many1 (satisfy (\ch -> not (isAlpha ch || ch `elem` "\"#'-_{"))) + <|> (do a <- satisfy (\ch -> isAlpha ch || ch == '_') + b <- many (satisfy (\ch -> isAlphaNum ch || ch == '_' || ch == '\'')) + return (a:b)) + <|> (do char '\"'; a <- hsString '\"'; char '\"'; return ("\""++a++"\"")) + <|> (do try (string "##"); return "#") + <|> (do char '\''; a <- hsString '\''; char '\''; return ("\'"++a++"\'")) + <|> (do try (string "--"); a <- many (satisfy (/= '\n')); return ("--"++a)) + <|> string "-" + <|> (do try (string "{-#"); optional (try linePragma); a <- hsComment; return ("{-#"++a)) + <|> (do try (string "{-"); a <- hsComment; return ("{-"++a)) + <|> string "{" + "Haskell source") + +linePragma :: Parser () +linePragma = do + state <- getState + spaces + string "LINE" + skipMany1 space + line <- many1 digit + skipMany1 space + char '\"' + file <- many (satisfy (/= '\"')) + char '\"' + spaces + string "#-}" + setState state + setPosition (newPos file (read line - 1) 1) hsComment :: Parser String hsComment = @@ -120,13 +139,14 @@ hsString quote = special :: Parser Token special = do + pos <- getPosition char '#' skipMany (oneOf " \t") key <- liftM2 (:) (letter <|> char '_') (many (alphaNum <|> char '_')) "hsc directive" skipMany (oneOf " \t") arg <- argument pzero - return (Special key arg) + return (Special pos key arg) argument :: Parser String -> Parser String argument eol = @@ -175,9 +195,9 @@ output flags name toks = let '/':_ -> progName _ -> "./"++progName - specials = [(key, arg) | Special key arg <- toks] + specials = [(pos, key, arg) | Special pos key arg <- toks] - needsC = any (\(key, _) -> key == "def") specials + needsC = any (\(_, key, _) -> key == "def") specials needsH = needsC includeGuard = map fixChar outHName @@ -202,6 +222,7 @@ output flags name toks = let outHeaderCProg specials++ "\nint main (void)\n{\n"++ outHeaderHs flags (if needsH then Just outHName else Nothing) specials++ + outHsLine (newPos name 0 1)++ concatMap outTokenHs toks++ " return 0;\n}\n" @@ -249,27 +270,28 @@ onlyOne what = do putStrLn ("Only one "++what++" may be specified") exitFailure -outHeaderCProg :: [(String, String)] -> String -outHeaderCProg = concatMap $ \(key, arg) -> case key of - "include" -> "#include "++arg++"\n" - "define" -> "#define "++arg++"\n" - "undef" -> "#undef "++arg++"\n" - "def" -> case arg of - 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n" - 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n" +outHeaderCProg :: [(SourcePos, String, String)] -> String +outHeaderCProg = + concatMap $ \(pos, key, arg) -> outCLine pos ++ case key of + "include" -> "#include "++arg++"\n" + "define" -> "#define "++arg++"\n" + "undef" -> "#undef "++arg++"\n" + "def" -> case arg of + 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n" + 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n" + _ -> "" + _ | conditional key -> "#"++key++" "++arg++"\n" + "let" -> case break (== '=') arg of + (_, "") -> "" + (header, _:body) -> case break isSpace header of + (name, args) -> + "#define hsc_"++name++"("++dropWhile isSpace args++") \ + \printf ("++joinLines body++");\n" _ -> "" - _ | conditional key -> "#"++key++" "++arg++"\n" - "let" -> case break (== '=') arg of - (_, "") -> "" - (header, _:body) -> case break isSpace header of - (name, args) -> - "#define hsc_"++name++"("++dropWhile isSpace args++") \ - \printf ("++joinLines body++");\n" - _ -> "" where joinLines = concat . intersperse " \\\n" . lines -outHeaderHs :: [Flag] -> Maybe String -> [(String, String)] -> String +outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String outHeaderHs flags inH toks = "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\ \ printf (\"{-# OPTIONS -optc-D__GLASGOW_HASKELL__=%d #-}\\n\", \ @@ -278,7 +300,7 @@ outHeaderHs flags inH toks = includeH++ concatMap outSpecial toks where - outSpecial (key, arg) = case key of + outSpecial (pos, key, arg) = outCLine pos ++ case key of "include" -> case inH of Nothing -> outOption ("-#include "++arg) Just _ -> "" @@ -304,53 +326,64 @@ outHeaderHs flags inH toks = showCString s++"\");\n" outTokenHs :: Token -> String -outTokenHs (Text s) = " fputs (\""++showCString s++"\", stdout);\n" -outTokenHs (Special key arg) = case key of - "include" -> "" - "define" -> "" - "undef" -> "" - "def" -> "" - _ | conditional key -> "#"++key++" "++arg++"\n" - "let" -> "" - _ -> " hsc_"++key++" ("++arg++");\n" +outTokenHs (Text pos text) = + case break (== '\n') text of + (all, []) -> outText all + (first, _:rest) -> + outText (first++"\n")++ + outHsLine pos++ + outText rest + where + outText s = " fputs (\""++showCString s++"\", stdout);\n" +outTokenHs (Special pos key arg) = + outCLine pos ++ case key of + "include" -> "" + "define" -> "" + "undef" -> "" + "def" -> "" + _ | conditional key -> "#"++key++" "++arg++"\n" + "let" -> "" + _ -> " hsc_"++key++" ("++arg++");\n" -outTokenH :: (String, String) -> String -outTokenH (key, arg) = case key of - "include" -> "#include "++arg++"\n" - "define" -> "#define " ++arg++"\n" - "undef" -> "#undef " ++arg++"\n" - "def" -> case arg of - 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n" - 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n" - 'i':'n':'l':'i':'n':'e':' ':_ -> - "#ifdef __GNUC__\n\ - \extern\n\ - \#endif\n"++ - arg++"\n" - _ -> "extern "++header++";\n" - where header = takeWhile (\c -> c/='{' && c/='=') arg - _ | conditional key -> "#"++key++" "++arg++"\n" - _ -> "" +outTokenH :: (SourcePos, String, String) -> String +outTokenH (pos, key, arg) = + outCLine pos ++ case key of + "include" -> "#include "++arg++"\n" + "define" -> "#define " ++arg++"\n" + "undef" -> "#undef " ++arg++"\n" + "def" -> case arg of + 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n" + 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n" + 'i':'n':'l':'i':'n':'e':' ':_ -> + "#ifdef __GNUC__\n\ + \extern\n\ + \#endif\n"++ + arg++"\n" + _ -> "extern "++header++";\n" + where header = takeWhile (\c -> c/='{' && c/='=') arg + _ | conditional key -> "#"++key++" "++arg++"\n" + _ -> "" -outTokenC :: (String, String) -> String -outTokenC (key, arg) = case key of - "def" -> case arg of - 's':'t':'r':'u':'c':'t':' ':_ -> "" - 't':'y':'p':'e':'d':'e':'f':' ':_ -> "" - 'i':'n':'l':'i':'n':'e':' ':_ -> - "#ifndef __GNUC__\n\ - \extern\n\ - \#endif\n"++ - header++ - "\n#ifndef __GNUC__\n\ - \;\n\ - \#else\n"++ - body++ - "\n#endif\n" - _ -> arg++"\n" - where (header, body) = span (\c -> c/='{' && c/='=') arg - _ | conditional key -> "#"++key++" "++arg++"\n" - _ -> "" +outTokenC :: (SourcePos, String, String) -> String +outTokenC (pos, key, arg) = + outCLine pos ++ case key of + "def" -> case arg of + 's':'t':'r':'u':'c':'t':' ':_ -> "" + 't':'y':'p':'e':'d':'e':'f':' ':_ -> "" + 'i':'n':'l':'i':'n':'e':' ':_ -> + "#ifndef __GNUC__\n\ + \extern\n\ + \#endif\n"++ + header++ + "\n#ifndef __GNUC__\n\ + \;\n\ + \#else\n"++ + body++ + "\n#endif\n" + _ -> arg++"\n" + where (header, body) = span (\c -> c/='{' && c/='=') arg + _ | conditional key -> "#"++key++" "++arg++"\n" + _ -> "" conditional :: String -> Bool conditional "if" = True @@ -362,6 +395,24 @@ conditional "endif" = True conditional "error" = True conditional _ = False +sourceFileName :: SourcePos -> String +sourceFileName pos = fileName (sourceName pos) + where + fileName s = case break (== '/') s of + (name, []) -> name + (_, _:rest) -> fileName rest + +outCLine :: SourcePos -> String +outCLine pos = + "# "++show (sourceLine pos)++ + " \""++showCString (sourceFileName pos)++"\"\n" + +outHsLine :: SourcePos -> String +outHsLine pos = + " printf (\"{-# LINE %d \\\"%s\\\" #-}\\n\", "++ + show (sourceLine pos + 1)++", \""++ + showCString (sourceFileName pos)++"\");\n" + showCString :: String -> String showCString = concatMap showCChar where -- 1.7.10.4