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) = "" 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 ()