Retro68/PrepareHeaders.hs
2014-09-17 02:10:04 +02:00

339 lines
14 KiB
Haskell

-- Copyright 2012 Wolfgang Thaller.
--
-- This file is part of Retro68.
--
-- Retro68 is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- Retro68 is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with Retro68. If not, see <http://www.gnu.org/licenses/>.
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 CallingConvention = Pascal | CCall
deriving(Show, Eq)
data Item = CharItem Char
| IgnoredItem
| FunctionItem CallingConvention 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 ++ ")")
isIDChar '_' = True
isIDChar c = isAlphaNum c
trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse
cleanup = unwords . words . trim
returnType = do
t <- identifier tp
ptrs <- many (reservedOp tp "*" >> return '*')
return $ t ++ ptrs
externApiDeclaration = do
(cconv, rettype) <-
(reserved tp "EXTERN_API" >> (fmap ((,) Pascal) $ fmap trim $ parens tp (balancedText False)))
<|> (reserved tp "EXTERN_API_C" >> (fmap ((,) CCall) $ fmap trim $ parens tp (balancedText False)))
<|> (reserved tp "pascal" >> fmap ((,) Pascal) returnType)
name <- identifier tp
arguments <- fmap (map cleanup) $ parens tp (commaSep tp $ balancedText True)
let hexwords = commaSep tp hexword
macroinline = do
inlinekey <- identifier tp
guard ("WORDINLINE" `isSuffixOf` inlinekey)
parens tp hexwords
plaininline = do
reservedOp tp "="
braces tp hexwords
inlines <- macroinline <|> plaininline <|> return []
semi tp
let arguments' | arguments == ["void"] = []
| otherwise = arguments
argumentNames = map (trim . reverse . takeWhile isIDChar . reverse . trim) arguments'
argumentTypes = map (trim . reverse . dropWhile isIDChar . reverse . trim) arguments'
return $ FunctionItem cconv 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
| "UPP" `isSuffixOf` t = Just PointerType
| "Ref" `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 cconv rettype name argumentTypes argumentNames words) = "<fun>"
outputItem typeMap (FunctionItem cconv 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
_ | cconv == CCall -> 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
cconvAttr = case cconv of
Pascal -> PP.text "__attribute__((stdcall))"
CCall -> PP.empty
in PP.render $
PP.text rettype <+> cconvAttr <+> 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 cconv 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 =
subq ++
pushes ++
map (\trapnum -> PP.text "\"dc.w" <+> PP.text "0x" <> PP.text (showHex trapnum "")
<> PP.text "\\n\\t\"") words
++ pop
(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 cconv rettype name argumentTypes argumentNames inlines _) = do
m <- get
return $ FunctionItem cconv 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
| isLower (head file) = putStrLn $ "Skipping " ++ file ++ " (standard library or MPW runtime)"
| ".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
let processed = concatMap (outputItem typeMap) $ collectPragmas $ items
if (file == "ConditionalMacros.h")
then do
hPutStrLn outf $ unlines [
"#define TARGET_CPU_68K 1",
"#define TARGET_OS_MAC 1",
"#define TARGET_RT_MAC_CFM 0",
"#define TARGET_RT_MAC_MACHO 0",
"#define TYPE_LONGLONG 1",
"#define pascal",
"#ifdef __cplusplus",
"#define TYPE_BOOL 1",
"#endif"
]
hPutStr outf $ unlines $
map (\line -> if line == "#elif defined(__GNUC__)"
then "#elif 0"
else line) $
lines $ processed
else
hPutStr outf $ processed
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 ()