Retro68/PrepareHeaders.hs
2012-04-15 03:34:57 +02:00

283 lines
12 KiB
Haskell

module Main where
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Language
import Text.ParserCombinators.Parsec.Token
import System.Directory
import System.FilePath
import Control.Monad(guard)
import Data.List(isSuffixOf)
import qualified Control.Exception
import System.IO
import qualified Text.PrettyPrint.HughesPJ as PP
import Text.PrettyPrint.HughesPJ((<+>),(<>),($$),($+$))
import Data.Char
import Numeric
import Data.Maybe(isJust)
import Control.Monad.State
import qualified Data.Map as Map
import System.Environment(getArgs)
data Item = CharItem Char
| IgnoredItem
| FunctionItem String String [String] [String] [Integer] (Maybe ParameterRegs)
| PragmaParameterItem String ParameterRegs
deriving(Show)
type Register = String
data ParameterRegs = ParameterRegs (Maybe Register) [Register]
deriving(Show)
tp = makeTokenParser javaStyle
item = (char '\r' >> return (CharItem '\n'))
<|> try externApiDeclaration
<|> try (string "= 0x4E90" >> return IgnoredItem)
<|> try (string "= 0x4E91" >> return IgnoredItem)
<|> try pragmaParameter
<|> fmap CharItem anyChar
balancedText stopAtComma = fmap (foldr ($) "") $
many (fmap (++) paranthesized <|> fmap (:) (noneOf (if stopAtComma then "()," else "()")))
where paranthesized = char '(' >> balancedText False >>= \xs -> char ')' >> return ('(' : xs ++ ")")
trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse
cleanup = unwords . words . trim
externApiDeclaration = do
reserved tp "EXTERN_API"
rettype <- fmap trim $ parens tp (balancedText False)
name <- identifier tp
arguments <- fmap (map cleanup) $ parens tp (commaSep tp $ balancedText True)
inlines <- option [] $ do
inlinekey <- identifier tp
guard ("WORDINLINE" `isSuffixOf` inlinekey)
parens tp (commaSep tp hexword)
semi tp
let arguments' | arguments == ["void"] = []
| otherwise = arguments
argumentNames = map (trim . reverse . takeWhile isAlphaNum . reverse . trim) arguments'
argumentTypes = map (trim . reverse . dropWhile isAlphaNum . reverse . trim) arguments'
return $ FunctionItem rettype name argumentTypes argumentNames inlines Nothing
pragmaParameter = do
reservedOp tp "#"
reserved tp "pragma"
reserved tp "parameter"
retval <- optionMaybe reg
name <- identifier tp
args <- parens tp (commaSep tp reg)
-- args <- option [] $ parens tp (fmap return $ reg)
-- let args = []
return $ PragmaParameterItem name (ParameterRegs retval args)
reg = (reserved tp "__A0" >> return "%%a0")
<|>(reserved tp "__A1" >> return "%%a1")
<|>(reserved tp "__A2" >> return "%%a2")
<|>(reserved tp "__D0" >> return "%%d0")
<|>(reserved tp "__D1" >> return "%%d1")
data TypeCategory = ByteType | WordType | LongType | PointerType | VoidType
deriving(Show, Eq)
classifyType tm t | "Ptr" `isSuffixOf` t = Just PointerType
| "*" `isSuffixOf` t = Just PointerType
| "Handle" `isSuffixOf` t = Just PointerType
classifyType tm "unsigned char" = Just ByteType
classifyType tm "signed char" = Just ByteType
classifyType tm "char" = Just ByteType
classifyType tm "short" = Just WordType
classifyType tm "long" = Just LongType
classifyType tm "void" = Just VoidType
classifyType tm t = Map.lookup t tm
hexword = integer tp
outputItem typeMap (CharItem c) = [c]
-- outputItem (FunctionItem rettype name argumentTypes argumentNames words) = "<fun>"
outputItem typeMap (FunctionItem rettype name argumentTypes argumentNames words Nothing)
| True, not (null words), Just retcat <- classifyType typeMap rettype
= let
helper = PP.text "__magic_inline_" <> PP.text name
magic = PP.text "__magic_inline_" <> PP.hcat (PP.punctuate (PP.char '_') (map (PP.text . hexword) words'))
hexword w = replicate (4 - length s) '0' ++ s where s = showHex w ""
magicArgTypes = case retcat of
ByteType -> reverse $ "char" : argumentTypes
WordType -> reverse $ "short" : argumentTypes
LongType -> reverse $ "long" : argumentTypes
PointerType -> reverse $ "long" : argumentTypes
VoidType -> reverse argumentTypes
magicArgValues = case retcat of
VoidType -> reverse argumentNames
_ -> reverse $ "0" : argumentNames
words' = case retcat of
VoidType -> words
ByteType -> words ++ [ 0x101f ] -- move.b (a7)+,d0
WordType -> words ++ [ 0x301f ] -- move.w (a7)+,d0
LongType -> words ++ [ 0x201f ] -- move.l (a7)+,d0
PointerType -> words ++ [ 0x201f ] -- move.l (a7)+,d0
in PP.render $
PP.text rettype <+> PP.text "__attribute__((stdcall))" <+> helper
<> PP.parens (PP.hsep $ PP.punctuate PP.comma $ map PP.text magicArgTypes)
<+> PP.text("__asm__") <> PP.parens ( PP.doubleQuotes magic )
<> PP.semi
$+$
PP.text "static inline" <+> PP.text rettype <+> PP.text name
<+> PP.parens (PP.hsep $ PP.punctuate PP.comma $ zipWith (\t n -> PP.text t <+> PP.text n) argumentTypes argumentNames) $$
PP.text "{" $+$ (PP.nest 4 $
(if retcat == VoidType then PP.empty else PP.text "return") <+>
helper <> PP.parens (PP.hsep $ PP.punctuate PP.comma $ map PP.text magicArgValues) <> PP.semi
) $+$ PP.text "}\n\n"
outputItem typeMap (FunctionItem rettype name argumentTypes argumentNames words mbParamRegs) =
PP.render $
linkage <+> PP.text rettype <+> PP.text name
<+> PP.parens (PP.hsep $ PP.punctuate PP.comma $ zipWith (\t n -> PP.text t <+> PP.text n) argumentTypes argumentNames) $$
if isJust mbCategories && not (null words)
then
PP.text "{" $+$ (PP.nest 4 $
addReturnValue $
PP.text "__asm__ __volatile__ (" $+$
PP.nest 4 (
PP.nest 4 (PP.vcat asmStatements) $+$
showConstraints outs $+$
showConstraints ins $+$
PP.text ": \"%a0\", \"%a1\", \"%d0\", \"%d1\", \"%d2\", \"memory\", \"cc\""
<> (if tooltrap then PP.text ", \"%a5\"" else PP.empty)
)
$+$ PP.text ");"
) $+$ PP.text "}\n\n"
else
PP.semi $+$
PP.text "//" <+> PP.text (show words) $+$
PP.text "//" <+> PP.text rettype <+> PP.text (show $ (classifyType typeMap) rettype) $+$
PP.text "//" <+> PP.text (show argumentTypes) <+> PP.text (show $ map (classifyType typeMap) argumentTypes) $+$
PP.text "\n" -- couldn't convert type
where
tooltrap = True -- trapnum >= 0xA800
linkage | null words = PP.text "extern"
| otherwise = PP.text "static inline"
mbCategories = do
retcat <- classifyType typeMap rettype
argcats <- mapM (classifyType typeMap) argumentTypes
return (retcat, argcats)
Just (returnCategory, argumentCategories) = mbCategories
returnsValue = returnCategory /= VoidType
addReturnValue body
| returnsValue = (PP.text rettype <+> PP.text "_ret;") $+$
body $+$
PP.text "return _ret;"
| otherwise = body
outs | returnsValue = [PP.text "\"=g\"(_ret)"]
| otherwise = []
ins = zipWith inputConstraint argumentCategories argumentNames
inputConstraint PointerType name = PP.text "\"m\"(*(char*)" <> PP.text name <> PP.text ")"
inputConstraint VoidType name = error $ "Void Parameter: " ++ name
inputConstraint _ name = PP.text "\"g\"(" <> PP.text name <> PP.text ")"
showConstraints constraints = PP.text ":" <+> PP.hsep (PP.punctuate PP.comma $ constraints)
asmStatements =
(if tooltrap then [-- PP.text "\"move.l %%a5, %%a4\\n\"",
PP.text "\"move.l 0x904.w, %%a5\\n\""] else []) ++
subq ++
pushes ++
map (\trapnum -> PP.text "\"dc.w" <+> PP.text "0x" <> PP.text (showHex trapnum "") <> PP.text "\\n\\t\"") words
++ pop
-- ++ (if tooltrap then [PP.text "\"move.l %%a4, %%a5\\n\""] else [])
(subq, pop) = case returnCategory of
VoidType -> ([], [])
_ -> (ifpascal [PP.text "\"subq #" <> PP.int size <> PP.text ", %%sp\\n\\t\""],
[PP.text "\"move" <> szLetter <+> src <+> PP.text ", %0\\n\\t\""])
where
size = case returnCategory of
PointerType -> 4 ; LongType -> 4 ; WordType -> 2 ; ByteType -> 2 {- keep stack aligned -}
szLetter = PP.text $ case returnCategory of
PointerType -> ".l" ; LongType -> ".l" ; WordType -> ".w" ; ByteType -> ".b"
src = case mbParamRegs of
Nothing -> PP.text "%%sp@+"
Just (ParameterRegs (Just r) _) -> PP.text r
Just (ParameterRegs Nothing _) -> error $ "no reg for return value: " ++ name
ifpascal x = case mbParamRegs of Nothing -> x ; Just _ -> []
pushes = case mbParamRegs of
Nothing -> zipWith (mkPush Nothing) argumentCategories
Just (ParameterRegs _ regs) -> zipWith3 mkPush (map Just regs) argumentCategories
$
map (\i -> PP.char '%' <> PP.int i) $
(if returnsValue then [1..] else [0..])
endtxt = PP.text "\\n\\t\""
mkPush Nothing PointerType operand = PP.text "\"pea" <+> operand <> endtxt
mkPush (Just reg) PointerType operand = PP.text "\"lea" <+> operand <> PP.comma <+> PP.text reg <> endtxt
mkPush mbReg size operand =
PP.text "\"move" <> PP.text sz <+> operand <> PP.comma <+> dst <> endtxt
where
sz = case size of
LongType -> ".l" ; WordType -> ".w" ; ByteType -> ".b"
dst = case mbReg of
Nothing -> PP.text "%%sp@-"
Just reg -> PP.text reg
outputItem _ _ = ""
collectPragmas xs = evalState (mapM doit xs) Map.empty
where
doit x@(PragmaParameterItem name params) = modify (Map.insert name params) >> return x
doit (FunctionItem rettype name argumentTypes argumentNames inlines _) = do
m <- get
return $ FunctionItem rettype name argumentTypes argumentNames inlines (Map.lookup name m)
doit x = return x
parseTypeMap tm = Map.fromList $ map handleLine $ lines tm
where
handleLine tml = case words tml of
(x : xs) -> (trim $ unwords xs, case x of
"B" -> ByteType ; "W" -> WordType ; "L" -> LongType ; "P" -> PointerType)
processFile inputDir outputDir file
| ".h" `isSuffixOf` file = do
print $ (outputDir </> takeFileName file)
-- readFile (inputDir </> file)
f <- openFile (inputDir </> file) ReadMode
hSetEncoding f latin1
txt <- hGetContents f
let parseResult = parse (many item) file txt
typeMap <- fmap parseTypeMap $ readFile "../Retro68/types.txt"
case parseResult of
Right items -> do
outf <- openFile (outputDir </> file) WriteMode
hSetEncoding outf latin1
when (file == "ConditionalMacros.h") $ do
hPutStrLn outf $ unlines [
"#define TARGET_CPU_68K 1",
"#define TYPE_LONGLONG 1",
"#define pascal",
"#ifdef __cplusplus",
"#define TYPE_BOOL 1",
"#endif"
]
hPutStr outf $ concatMap (outputItem typeMap) $ collectPragmas $ items
hClose outf
Left err -> putStrLn $ file ++ ": " ++ show err
| otherwise = do
putStrLn $ "Unknown: " ++ file
main = do
[inputDir,outputDir] <- getArgs
files <- getDirectoryContents inputDir
Control.Exception.try (createDirectory outputDir) :: IO (Either Control.Exception.IOException ())
mapM (processFile inputDir outputDir) files
return ()