Commit a1f2e061 authored by Kenton Varda's avatar Kenton Varda

Working on C++ code generator, need to sleep now though.

parent ed97f68a
......@@ -7,18 +7,25 @@ author: kenton
executable capnproto-compiler
hs-source-dirs: src
main-is: Main.hs
build-depends:
build-depends:
base >= 4,
parsec,
mtl,
containers
containers,
file-embed,
bytestring,
Crypto,
utf8-string,
hastache
ghc-options: -Wall -fno-warn-missing-signatures
other-modules:
other-modules:
Lexer,
Token,
Grammar,
Parser,
Compiler,
Semantics,
Util
Util,
CxxGenerator,
WireFormat
......@@ -28,8 +28,9 @@ import Semantics
import Token(Located(Located))
import Parser(parseFile)
import qualified Data.Map as Map
import Data.Map((!))
import qualified Data.List as List
import Data.Maybe(mapMaybe)
import Data.Maybe(mapMaybe, fromMaybe)
import Text.Parsec.Pos(SourcePos, newPos)
import Text.Parsec.Error(ParseError, newErrorMessage, Message(Message, Expect))
import Text.Printf(printf)
......@@ -162,6 +163,14 @@ fromIntegerChecked name pos x = result where
then succeed unchecked
else makeError pos (printf "Integer %d out of range for type %s." x name)
compileFieldAssignment :: StructDesc -> (Located String, Located FieldValue)
-> Status (FieldDesc, ValueDesc)
compileFieldAssignment desc (Located namePos name, Located valPos val) =
case lookupMember name (structMemberMap desc) of
Just (DescField field) ->
fmap (\x -> (field, x)) (compileValue valPos (fieldType field) val)
_ -> makeError namePos (printf "Struct %s has no field %s." (structName desc) name)
compileValue :: SourcePos -> TypeDesc -> FieldValue -> Status ValueDesc
compileValue _ (BuiltinType BuiltinVoid) VoidFieldValue = succeed VoidDesc
compileValue _ (BuiltinType BuiltinBool) (BoolFieldValue x) = succeed (BoolDesc x)
......@@ -184,16 +193,32 @@ compileValue _ (BuiltinType BuiltinData) (StringFieldValue x) =
compileValue pos (EnumType desc) (IdentifierFieldValue name) =
case lookupMember name (enumMemberMap desc) of
Just (DescEnumValue value) -> succeed (EnumValueValueDesc value)
_ -> makeError pos (printf "Enum type %s has no value %s." (enumName desc) name)
compileValue _ (StructType desc) (RecordFieldValue fields) = result where
result = fmap StructValueDesc (doAll (map compileFieldAssignment fields))
compileFieldAssignment :: (Located String, Located FieldValue) -> Status (FieldDesc, ValueDesc)
compileFieldAssignment (Located namePos name, Located valPos val) =
case lookupMember name (structMemberMap desc) of
Just (DescField field) ->
fmap (\x -> (field, x)) (compileValue valPos (fieldType field) val)
_ -> makeError namePos (printf "Struct %s has no field %s." (structName desc) name)
_ -> makeError pos (printf "Enum type '%s' has no value '%s'." (enumName desc) name)
compileValue pos (StructType desc) (RecordFieldValue fields) = do
assignments <- doAll (map (compileFieldAssignment desc) fields)
-- Check for duplicate fields.
_ <- let
dupes = findDupesBy id [fieldName f | (f, _) <- assignments]
errors = map dupFieldError dupes
dupFieldError [] = error "empty group?"
dupFieldError (name:_) = makeError pos
(printf "Struct literal assigns field '%s' multiple times." name)
in doAll errors
-- Check for multiple assignments in the same union.
_ <- let
dupes = findDupesBy (\(_, u) -> unionName u)
[(f, u) | (f@(FieldDesc {fieldUnion = Just u}), _) <- assignments]
errors = map dupUnionError dupes
dupUnionError [] = error "empty group?"
dupUnionError dupFields@((_, u):_) = makeError pos (printf
"Struct literal assigns multiple fields belonging to the same union '%s': %s"
(unionName u) (delimit ", " (map (\(f, _) -> fieldName f) dupFields)))
in doAll errors
return (StructValueDesc assignments)
compileValue _ (ListType t) (ListFieldValue l) =
fmap ListDesc (doAll [ compileValue vpos t v | Located vpos v <- l ])
......@@ -251,6 +276,13 @@ compileType scope (TypeExpression n (param:moreParams)) = do
------------------------------------------------------------------------------------------
findDupesBy :: Ord a => (b -> a) -> [b] -> [[b]]
findDupesBy getKey items = let
compareItems a b = compare (getKey a) (getKey b)
eqItems a b = (getKey a) == (getKey b)
grouped = List.groupBy eqItems $ List.sortBy compareItems items
in [ item | item@(_:_:_) <- grouped ]
requireSequentialNumbering :: String -> [Located Integer] -> Status ()
requireSequentialNumbering kind items = Active () (loop undefined (-1) sortedItems) where
sortedItems = List.sort items
......@@ -304,6 +336,117 @@ requireNoMoreThanOneFieldNumberLessThan name pos num fields = Active () errors w
------------------------------------------------------------------------------------------
initialPackingState = PackingState 0 0 0 0 0 0
packValue :: FieldSize -> PackingState -> (Integer, PackingState)
packValue Size64 s@(PackingState { packingDataSize = ds }) =
(ds, s { packingDataSize = ds + 1 })
packValue SizeReference s@(PackingState { packingReferenceCount = rc }) =
(rc, s { packingReferenceCount = rc + 1 })
packValue (SizeInlineComposite _ _) _ = error "Inline fields not yet supported."
packValue Size32 s@(PackingState { packingHole32 = 0 }) =
case packValue Size64 s of
(o64, s2) -> (o64 * 2, s2 { packingHole32 = o64 * 2 + 1 })
packValue Size32 s@(PackingState { packingHole32 = h32 }) =
(h32, s { packingHole32 = 0 })
packValue Size16 s@(PackingState { packingHole16 = 0 }) =
case packValue Size32 s of
(o32, s2) -> (o32 * 2, s2 { packingHole16 = o32 * 2 + 1 })
packValue Size16 s@(PackingState { packingHole16 = h16 }) =
(h16, s { packingHole16 = 0 })
packValue Size8 s@(PackingState { packingHole8 = 0 }) =
case packValue Size16 s of
(o16, s2) -> (o16 * 2, s2 { packingHole8 = o16 * 2 + 1 })
packValue Size8 s@(PackingState { packingHole8 = h8 }) =
(h8, s { packingHole8 = 0 })
packValue Size1 s@(PackingState { packingHole1 = 0 }) =
case packValue Size8 s of
(o8, s2) -> (o8 * 8, s2 { packingHole1 = o8 * 8 + 1 })
packValue Size1 s@(PackingState { packingHole1 = h1 }) =
(h1, s { packingHole1 = if mod (h1 + 1) 8 == 0 then 0 else h1 + 1 })
packValue Size0 s = (0, s)
initialUnionPackingState = UnionPackingState Nothing Nothing Nothing
packUnionizedValue :: FieldSize -- Size of field to pack.
-> Bool -- Whether the field is retroactively unionized.
-> UnionPackingState -- Current layout of the union
-> PackingState -- Current layout of the struct.
-> (Integer, UnionPackingState, PackingState)
packUnionizedValue (SizeInlineComposite _ _) _ _ _ = error "Can't put inline composite into union."
packUnionizedValue Size0 _ u s = (0, u, s)
-- Pack reference when we already have a reference slot allocated.
packUnionizedValue SizeReference _ u@(UnionPackingState _ (Just offset) _) s = (offset, u, s)
-- Pack reference when we don't have a reference slot.
packUnionizedValue SizeReference _ (UnionPackingState d Nothing retro) s = (offset, u2, s2) where
(offset, s2) = packValue SizeReference s
u2 = UnionPackingState d (Just offset) retro
-- Pack data that fits into the retro slot.
packUnionizedValue size _ u@(UnionPackingState _ _ (Just (offset, retroSize))) s
| sizeInBits retroSize >= sizeInBits size =
(offset * div (sizeInBits retroSize) (sizeInBits size), u, s)
-- Pack data when a data word has been allocated.
packUnionizedValue size _ u@(UnionPackingState (Just offset) _ _) s =
(offset * div 64 (sizeInBits size), u, s)
-- Pack retroactive data when no data word has been allocated.
packUnionizedValue size True (UnionPackingState Nothing r Nothing) s =
(offset, u2, s2) where
(offset, s2) = packValue size s
u2 = UnionPackingState Nothing r (Just (offset, size))
-- Pack non-retroactive data when no data word has been allocated.
packUnionizedValue size _ (UnionPackingState Nothing r retro) s =
(offset * div 64 (sizeInBits size), u2, s2) where
(offset, s2) = packValue Size64 s
u2 = UnionPackingState (Just offset) r retro
-- Determine the offset for the given field, and update the packing states to include the field.
packField :: FieldDesc -> PackingState -> Map.Map Integer UnionPackingState
-> (Integer, PackingState, Map.Map Integer UnionPackingState)
packField fieldDesc state unionState =
case fieldUnion fieldDesc of
Nothing -> let
(offset, newState) = packValue (fieldSize $ fieldType fieldDesc) state
in (offset, newState, unionState)
Just unionDesc -> let
n = unionNumber unionDesc
oldUnionPacking = fromMaybe initialUnionPackingState (Map.lookup n unionState)
isRetro = fieldNumber fieldDesc < unionNumber unionDesc
(offset, newUnionPacking, newState) =
packUnionizedValue (fieldSize $ fieldType fieldDesc) isRetro oldUnionPacking state
newUnionState = Map.insert n newUnionPacking unionState
in (offset, newState, newUnionState)
-- Determine the offset for the given union, and update the packing states to include the union.
-- Specifically, this packs the union tag, *not* the fields of the union.
packUnion :: UnionDesc -> PackingState -> Map.Map Integer UnionPackingState
-> (Integer, PackingState, Map.Map Integer UnionPackingState)
packUnion _ state unionState = (offset, newState, unionState) where
(offset, newState) = packValue Size8 state
packFields :: [FieldDesc] -> [UnionDesc]
-> (PackingState, Map.Map Integer UnionPackingState, Map.Map Integer (Integer, PackingState))
packFields fields unions = (finalState, finalUnionState, Map.fromList packedItems) where
items = [(fieldNumber d, packField d) | d <- fields] ++
[(unionNumber d, packUnion d) | d <- unions]
itemsByNumber = List.sortBy compareNumbers items
compareNumbers (a, _) (b, _) = compare a b
(finalState, finalUnionState, packedItems) =
foldl packItem (initialPackingState, Map.empty, []) itemsByNumber
packItem (state, unionState, packed) (n, item) =
(newState, newUnionState, (n, (offset, newState)):packed) where
(offset, newState, newUnionState) = item state unionState
------------------------------------------------------------------------------------------
-- For CompiledMemberStatus, the second parameter contains members that should be inserted into the
-- parent's map, e.g. fields defined in a union which should be considered members of the parent
-- struct as well. Usually (except in the case of unions) this map is empty.
......@@ -385,11 +528,16 @@ compileDecl scope (StructDecl (Located _ name) decls) =
[ num | UnionDecl _ num _ <- decls ])
requireSequentialNumbering "Fields" fieldNums
requireFieldNumbersInRange fieldNums
return (DescStruct StructDesc
return (let
fields = [d | DescField d <- members]
unions = [d | DescUnion d <- members]
(packing, unionPackingMap, fieldPackingMap) = packFields fields unions
in DescStruct StructDesc
{ structName = name
, structParent = scope
, structFields = [d | DescField d <- members]
, structUnions = [d | DescUnion d <- members]
, structPacking = packing
, structFields = fields
, structUnions = unions
, structNestedAliases = [d | DescAlias d <- members]
, structNestedConstants = [d | DescConstant d <- members]
, structNestedEnums = [d | DescEnum d <- members]
......@@ -398,6 +546,8 @@ compileDecl scope (StructDecl (Located _ name) decls) =
, structOptions = options
, structMemberMap = memberMap
, structStatements = statements
, structFieldPackingMap = fieldPackingMap
, structUnionPackingMap = unionPackingMap
})))
compileDecl (DescStruct parent) (UnionDecl (Located _ name) (Located numPos number) decls) =
......@@ -405,10 +555,18 @@ compileDecl (DescStruct parent) (UnionDecl (Located _ name) (Located numPos numb
(_, _, options, statements) <- compileChildDecls desc decls
fields <- return [f | f <- structFields parent, fieldInUnion name f]
requireNoMoreThanOneFieldNumberLessThan name numPos number fields
return (DescUnion UnionDesc
return (let
(tagOffset, tagPacking) = structFieldPackingMap parent ! number
unionPacking = structUnionPackingMap parent ! number
in DescUnion UnionDesc
{ unionName = name
, unionParent = parent
, unionNumber = number
, unionTagOffset = tagOffset
, unionTagPacking = tagPacking
, unionDataOffset = unionPackDataOffset unionPacking
, unionReferenceOffset = unionPackReferenceOffset unionPacking
, unionRetroactiveSlot = unionPackRetroactiveSlot unionPacking
, unionFields = fields
, unionOptions = options
, unionStatements = statements
......@@ -432,10 +590,14 @@ compileDecl scope@(DescStruct parent)
Just (Located pos value) -> fmap Just (compileValue pos typeDesc value)
Nothing -> return Nothing
(_, _, options, statements) <- compileChildDecls desc decls
return (DescField FieldDesc
return (let
(offset, packing) = structFieldPackingMap parent ! number
in DescField FieldDesc
{ fieldName = name
, fieldParent = parent
, fieldNumber = number
, fieldOffset = offset
, fieldPacking = packing
, fieldUnion = unionDesc
, fieldType = typeDesc
, fieldDefaultValue = defaultDesc
......
-- Copyright (c) 2013, Kenton Varda <temporal@gmail.com>
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--
-- 1. Redistributions of source code must retain the above copyright notice, this
-- list of conditions and the following disclaimer.
-- 2. Redistributions in binary form must reproduce the above copyright notice,
-- this list of conditions and the following disclaimer in the documentation
-- and/or other materials provided with the distribution.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
-- (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
-- LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
-- ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
{-# LANGUAGE TemplateHaskell #-}
module CxxGenerator(generateCxx) where
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.UTF8 as UTF8
import Data.FileEmbed(embedFile)
import Data.Char(ord)
import qualified Data.Digest.MD5 as MD5
import Text.Printf(printf)
import Text.Hastache
import Text.Hastache.Context
import Semantics
import Util
-- MuNothing isn't considered a false value for the purpose of {{#variable}} expansion. Use this
-- instead.
muNull = MuBool False;
hashString :: String -> String
hashString str =
concatMap (printf "%02x" . fromEnum) $
MD5.hash $
ByteString.unpack $
UTF8.fromString str
isPrimitive (BuiltinType _) = True
isPrimitive (EnumType _) = True
isPrimitive (StructType _) = False
isPrimitive (InterfaceType _) = False
isPrimitive (ListType _) = False
isStruct (StructType _) = True
isStruct _ = False
isList (ListType _) = True
isList _ = False
isPrimitiveList (ListType t) = isPrimitive t
isPrimitiveList _ = False
isStructList (ListType t) = isStruct t
isStructList _ = False
cxxTypeString (BuiltinType BuiltinVoid) = "void"
cxxTypeString (BuiltinType BuiltinBool) = "bool"
cxxTypeString (BuiltinType BuiltinInt8) = "int8_t"
cxxTypeString (BuiltinType BuiltinInt16) = "int16_t"
cxxTypeString (BuiltinType BuiltinInt32) = "int32_t"
cxxTypeString (BuiltinType BuiltinInt64) = "int64_t"
cxxTypeString (BuiltinType BuiltinUInt8) = "uint8_t"
cxxTypeString (BuiltinType BuiltinUInt16) = "uint16_t"
cxxTypeString (BuiltinType BuiltinUInt32) = "uint32_t"
cxxTypeString (BuiltinType BuiltinUInt64) = "uint64_t"
cxxTypeString (BuiltinType BuiltinFloat32) = "float"
cxxTypeString (BuiltinType BuiltinFloat64) = "double"
cxxTypeString (BuiltinType BuiltinText) = "TODO"
cxxTypeString (BuiltinType BuiltinData) = "TODO"
cxxTypeString (EnumType desc) = enumName desc
cxxTypeString (StructType desc) = structName desc
cxxTypeString (InterfaceType desc) = interfaceName desc
cxxTypeString (ListType t) = concat ["::capnproto::List<", cxxTypeString t, ">"]
cxxFieldSizeString Size0 = "VOID";
cxxFieldSizeString Size1 = "BIT";
cxxFieldSizeString Size8 = "BYTE";
cxxFieldSizeString Size16 = "TWO_BYTES";
cxxFieldSizeString Size32 = "FOUR_BYTES";
cxxFieldSizeString Size64 = "EIGHT_BYTES";
cxxFieldSizeString SizeReference = "REFERENCE";
cxxFieldSizeString (SizeInlineComposite _ _) = "INLINE_COMPOSITE";
cEscape [] = []
cEscape (first:rest) = result where
eRest = cEscape rest
result = case first of
'\a' -> '\\':'a':eRest
'\b' -> '\\':'b':eRest
'\f' -> '\\':'f':eRest
'\n' -> '\\':'n':eRest
'\r' -> '\\':'r':eRest
'\t' -> '\\':'t':eRest
'\v' -> '\\':'v':eRest
'\'' -> '\\':'\'':eRest
'\"' -> '\\':'\"':eRest
'\\' -> '\\':'\\':eRest
'?' -> '\\':'?':eRest
c | c < ' ' || c > '~' -> '\\':(printf "%03o" (ord c) ++ eRest)
c -> c:eRest
cxxValueString VoidDesc = error "Can't stringify void value."
cxxValueString (BoolDesc b) = if b then "true" else "false"
cxxValueString (Int8Desc i) = show i
cxxValueString (Int16Desc i) = show i
cxxValueString (Int32Desc i) = show i
cxxValueString (Int64Desc i) = show i ++ "ll"
cxxValueString (UInt8Desc i) = show i
cxxValueString (UInt16Desc i) = show i
cxxValueString (UInt32Desc i) = show i ++ "u"
cxxValueString (UInt64Desc i) = show i ++ "llu"
cxxValueString (Float32Desc x) = show x ++ "f"
cxxValueString (Float64Desc x) = show x
cxxValueString (TextDesc s) = "\"" ++ cEscape s ++ "\""
cxxValueString (DataDesc _) = error "Data defaults are encoded as bytes."
cxxValueString (EnumValueValueDesc v) =
cxxTypeString (EnumType $ enumValueParent v) ++ "::" ++
toUpperCaseWithUnderscores (enumValueName v)
cxxValueString (StructValueDesc _) = error "Struct defaults are encoded as bytes."
cxxValueString (ListDesc _) = error "List defaults are encoded as bytes."
cxxDefaultDefault (BuiltinType BuiltinVoid) = error "Can't stringify void value."
cxxDefaultDefault (BuiltinType BuiltinBool) = "false"
cxxDefaultDefault (BuiltinType BuiltinInt8) = "0"
cxxDefaultDefault (BuiltinType BuiltinInt16) = "0"
cxxDefaultDefault (BuiltinType BuiltinInt32) = "0"
cxxDefaultDefault (BuiltinType BuiltinInt64) = "0"
cxxDefaultDefault (BuiltinType BuiltinUInt8) = "0"
cxxDefaultDefault (BuiltinType BuiltinUInt16) = "0"
cxxDefaultDefault (BuiltinType BuiltinUInt32) = "0"
cxxDefaultDefault (BuiltinType BuiltinUInt64) = "0"
cxxDefaultDefault (BuiltinType BuiltinFloat32) = "0"
cxxDefaultDefault (BuiltinType BuiltinFloat64) = "0"
cxxDefaultDefault (BuiltinType BuiltinText) = "\"\""
cxxDefaultDefault (BuiltinType BuiltinData) = error "Data defaults are encoded as bytes."
cxxDefaultDefault (EnumType desc) = cxxValueString $ EnumValueValueDesc $ head $ enumValues desc
cxxDefaultDefault (StructType _) = error "Struct defaults are encoded as bytes."
cxxDefaultDefault (InterfaceType _) = error "Interfaces have no default value."
cxxDefaultDefault (ListType _) = error "List defaults are encoded as bytes."
elementType (ListType t) = t
elementType _ = error "Called elementType on non-list."
fieldContext parent desc = mkStrContext context where
context "fieldName" = MuVariable $ fieldName desc
context "fieldDecl" = MuVariable $ descToCode "" (DescField desc)
context "fieldTitleCase" = MuVariable $ toTitleCase $ fieldName desc
context "fieldUpperCase" = MuVariable $ toUpperCaseWithUnderscores $ fieldName desc
context "fieldIsPrimitive" = MuBool $ isPrimitive $ fieldType desc
context "fieldIsStruct" = MuBool $ isStruct $ fieldType desc
context "fieldIsList" = MuBool $ isList $ fieldType desc
context "fieldIsPrimitiveList" = MuBool $ isPrimitiveList $ fieldType desc
context "fieldIsStructList" = MuBool $ isStructList $ fieldType desc
context "fieldDefaultBytes" = muNull
context "fieldType" = MuVariable $ cxxTypeString $ fieldType desc
context "fieldOffset" = MuVariable $ fieldOffset desc
context "fieldDefaultValue" = case fieldDefaultValue desc of
Just v -> MuVariable $ cxxValueString v
Nothing -> MuVariable $ cxxDefaultDefault $ fieldType desc
context "fieldElementSize" =
MuVariable $ cxxFieldSizeString $ fieldSize $ elementType $ fieldType desc
context s = parent s
structContext parent desc = mkStrContext context where
context "structName" = MuVariable $ structName desc
context "structFields" = MuList $ map (fieldContext context) $ structFields desc
context "structChildren" = MuList [] -- TODO
context s = parent s
fileContext desc = mkStrContext context where
context "fileName" = MuVariable $ fileName desc
context "fileIncludeGuard" = MuVariable $
"CAPNPROTO_INCLUDED_" ++ hashString (fileName desc)
context "fileNamespaces" = MuList [] -- TODO
context "fileStructs" = MuList $ map (structContext context) $ fileStructs desc
context s = MuVariable $ concat ["@@@", s, "@@@"]
headerTemplate :: String
headerTemplate = UTF8.toString $(embedFile "src/c++-header.mustache")
-- Sadly it appears that hashtache requires access to the IO monad, even when template inclusion
-- is disabled.
hastacheConfig :: MuConfig IO
hastacheConfig = MuConfig
{ muEscapeFunc = emptyEscape
, muTemplateFileDir = Nothing
, muTemplateFileExt = Nothing
, muTemplateRead = \_ -> return Nothing
}
generateCxx file =
hastacheStr hastacheConfig (encodeStr headerTemplate) (fileContext file)
......@@ -30,11 +30,11 @@ import qualified Text.Parsec.Token as T
import Text.Parsec.Language (emptyDef)
import Token
import Data.Char (isUpper, isLower)
import Data.List (find)
import Data.Maybe (isJust)
keywords =
[ (InKeyword, "in")
[ (TrueKeyword, "true")
, (FalseKeyword, "false")
, (InKeyword, "in")
, (OfKeyword, "of")
, (OnKeyword, "on")
, (AsKeyword, "as")
......@@ -96,7 +96,7 @@ hasUppercaseAcronym _ = False
identifier :: Parser Token
identifier = do
text <- rawIdentifier
when (isJust $ find (== '_') text) $
when (elem '_' text) $
fail "Identifiers containing underscores are reserved for the implementation. Use \
\camelCase style for multi-word names."
when (hasUppercaseAcronym text) $
......
......@@ -30,6 +30,8 @@ import Text.Parsec.Pos
import Text.Parsec.Error
import Text.Printf(printf)
import qualified Data.List as List
import CxxGenerator(generateCxx)
import qualified Data.ByteString.Lazy.Char8 as LZ
main::IO()
main = do
......@@ -39,7 +41,11 @@ main = do
handleFile filename = do
text <- readFile filename
case parseAndCompileFile filename text of
Active desc [] -> print desc
Active desc [] -> do
print desc
cxx <- generateCxx desc
LZ.putStr cxx
Active _ e -> mapM_ printError (List.sortBy compareErrors e)
Failed e -> mapM_ printError (List.sortBy compareErrors e)
......
......@@ -48,6 +48,8 @@ tokenErrorString Period = "\".\""
tokenErrorString EqualsSign = "\"=\""
tokenErrorString MinusSign = "\"-\""
tokenErrorString ExclamationPoint = "\"!\""
tokenErrorString TrueKeyword = "keyword \"true\""
tokenErrorString FalseKeyword = "keyword \"false\""
tokenErrorString InKeyword = "keyword \"in\""
tokenErrorString OfKeyword = "keyword \"of\""
tokenErrorString OnKeyword = "keyword \"on\""
......@@ -79,6 +81,10 @@ matchBracketedList t = case locatedValue t of { (BracketedList v) -> Jus
matchLiteralInt t = case locatedValue t of { (LiteralInt v) -> Just v; _ -> Nothing }
matchLiteralFloat t = case locatedValue t of { (LiteralFloat v) -> Just v; _ -> Nothing }
matchLiteralString t = case locatedValue t of { (LiteralString v) -> Just v; _ -> Nothing }
matchLiteralBool t = case locatedValue t of
TrueKeyword -> Just True
FalseKeyword -> Just False
_ -> Nothing
matchSimpleToken expected t = if locatedValue t == expected then Just () else Nothing
varIdentifier = tokenParser matchIdentifier
......@@ -96,6 +102,7 @@ anyIdentifier = tokenParser matchIdentifier
literalInt = tokenParser matchLiteralInt <?> "integer"
literalFloat = tokenParser matchLiteralFloat <?> "floating-point number"
literalString = tokenParser matchLiteralString <?> "string"
literalBool = tokenParser matchLiteralBool <?> "boolean"
atSign = tokenParser (matchSimpleToken AtSign) <?> "\"@\""
colon = tokenParser (matchSimpleToken Colon) <?> "\":\""
......@@ -231,7 +238,8 @@ fieldDecl statements = do
negativeFieldValue = liftM (IntegerFieldValue . negate) literalInt
<|> liftM (FloatFieldValue . negate) literalFloat
fieldValue = liftM IntegerFieldValue literalInt
fieldValue = liftM BoolFieldValue literalBool
<|> liftM IntegerFieldValue literalInt
<|> liftM FloatFieldValue literalFloat
<|> liftM StringFieldValue literalString
<|> liftM IdentifierFieldValue varIdentifier
......
......@@ -147,6 +147,82 @@ data TypeDesc = BuiltinType BuiltinType
| InterfaceType InterfaceDesc
| ListType TypeDesc
data PackingState = PackingState
{ packingHole1 :: Integer
, packingHole8 :: Integer
, packingHole16 :: Integer
, packingHole32 :: Integer
, packingDataSize :: Integer
, packingReferenceCount :: Integer
}
-- Represents the current packing state of a union. The parameters are:
-- - The offset of a 64-bit word in the data segment allocated to the union.
-- - The offset of a reference allocated to the union.
-- - The offset of a smaller piece of the data segment allocated to the union. Such a smaller
-- piece exists if one field in the union has lower number than the union itself -- in this case,
-- this is the piece that had been allocated to that field, and is now retroactively part of the
-- union.
data UnionPackingState = UnionPackingState
{ unionPackDataOffset :: Maybe Integer
, unionPackReferenceOffset :: Maybe Integer
, unionPackRetroactiveSlot :: Maybe (Integer, FieldSize)
}
data FieldSize = Size0 | Size1 | Size8 | Size16 | Size32 | Size64 | SizeReference
| SizeInlineComposite Integer Integer
fieldSize (BuiltinType BuiltinVoid) = Size0
fieldSize (BuiltinType BuiltinBool) = Size1
fieldSize (BuiltinType BuiltinInt8) = Size8
fieldSize (BuiltinType BuiltinInt16) = Size16
fieldSize (BuiltinType BuiltinInt32) = Size32
fieldSize (BuiltinType BuiltinInt64) = Size64
fieldSize (BuiltinType BuiltinUInt8) = Size8
fieldSize (BuiltinType BuiltinUInt16) = Size16
fieldSize (BuiltinType BuiltinUInt32) = Size32
fieldSize (BuiltinType BuiltinUInt64) = Size64
fieldSize (BuiltinType BuiltinFloat32) = Size32
fieldSize (BuiltinType BuiltinFloat64) = Size64
fieldSize (BuiltinType BuiltinText) = SizeReference
fieldSize (BuiltinType BuiltinData) = SizeReference
fieldSize (EnumType _) = Size16 -- TODO: ??
fieldSize (StructType _) = SizeReference
fieldSize (InterfaceType _) = SizeReference
fieldSize (ListType _) = SizeReference
fieldValueSize VoidDesc = Size0
fieldValueSize (BoolDesc _) = Size1
fieldValueSize (Int8Desc _) = Size8
fieldValueSize (Int16Desc _) = Size16
fieldValueSize (Int32Desc _) = Size32
fieldValueSize (Int64Desc _) = Size64
fieldValueSize (UInt8Desc _) = Size8
fieldValueSize (UInt16Desc _) = Size16
fieldValueSize (UInt32Desc _) = Size32
fieldValueSize (UInt64Desc _) = Size64
fieldValueSize (Float32Desc _) = Size32
fieldValueSize (Float64Desc _) = Size64
fieldValueSize (TextDesc _) = SizeReference
fieldValueSize (DataDesc _) = SizeReference
fieldValueSize (EnumValueValueDesc _) = Size16
fieldValueSize (StructValueDesc _) = SizeReference
fieldValueSize (ListDesc _) = SizeReference
elementSize (StructType StructDesc { structPacking =
PackingState { packingDataSize = ds, packingReferenceCount = rc } }) =
SizeInlineComposite ds rc
elementSize t = fieldSize t
sizeInBits Size0 = 0
sizeInBits Size1 = 1
sizeInBits Size8 = 8
sizeInBits Size16 = 16
sizeInBits Size32 = 32
sizeInBits Size64 = 64
sizeInBits SizeReference = 64
sizeInBits (SizeInlineComposite d r) = (d + r) * 64
-- Render the type descriptor's name as a string, appropriate for use in the given scope.
typeName :: Desc -> TypeDesc -> String
typeName _ (BuiltinType t) = builtinTypeName t -- TODO: Check for shadowing.
......@@ -220,6 +296,7 @@ data EnumValueDesc = EnumValueDesc
data StructDesc = StructDesc
{ structName :: String
, structParent :: Desc
, structPacking :: PackingState
, structFields :: [FieldDesc]
, structUnions :: [UnionDesc]
, structNestedAliases :: [AliasDesc]
......@@ -230,12 +307,23 @@ data StructDesc = StructDesc
, structOptions :: OptionMap
, structMemberMap :: MemberMap
, structStatements :: [CompiledStatement]
-- Don't use these directly, use the members of FieldDesc and UnionDesc.
-- These fields are exposed here only because I was too lazy to create a way to pass them on
-- the side when compiling members of a struct.
, structFieldPackingMap :: Map.Map Integer (Integer, PackingState)
, structUnionPackingMap :: Map.Map Integer UnionPackingState
}
data UnionDesc = UnionDesc
{ unionName :: String
, unionParent :: StructDesc
, unionNumber :: Integer
, unionTagOffset :: Integer
, unionTagPacking :: PackingState
, unionDataOffset :: Maybe Integer
, unionReferenceOffset :: Maybe Integer
, unionRetroactiveSlot :: Maybe (Integer, FieldSize)
, unionFields :: [FieldDesc]
, unionOptions :: OptionMap
, unionStatements :: [CompiledStatement]
......@@ -245,6 +333,8 @@ data FieldDesc = FieldDesc
{ fieldName :: String
, fieldParent :: StructDesc
, fieldNumber :: Integer
, fieldOffset :: Integer
, fieldPacking :: PackingState -- PackingState for the struct *if* this were the final field.
, fieldUnion :: Maybe UnionDesc
, fieldType :: TypeDesc
, fieldDefaultValue :: Maybe ValueDesc
......@@ -313,15 +403,23 @@ descToCode indent (DescEnumValue desc) = printf "%s%s = %d%s" indent
descToCode indent (DescStruct desc) = printf "%sstruct %s%s" indent
(structName desc)
(blockCode indent (structStatements desc))
descToCode indent (DescField desc) = printf "%s%s@%d%s: %s%s%s" indent
descToCode indent (DescField desc) = printf "%s%s@%d%s: %s%s; # %s\n" indent
(fieldName desc) (fieldNumber desc)
(case fieldUnion desc of { Nothing -> ""; Just u -> " in " ++ unionName u})
(typeName (DescStruct (fieldParent desc)) (fieldType desc))
(case fieldDefaultValue desc of { Nothing -> ""; Just v -> " = " ++ valueString v; })
(maybeBlockCode indent $ fieldStatements desc)
descToCode indent (DescUnion desc) = printf "%sunion %s@%d%s" indent
(case fieldSize $ fieldType desc of
SizeReference -> printf "ref[%d]" $ fieldOffset desc
SizeInlineComposite _ _ -> "??"
s -> let
bits = (sizeInBits s)
offset = fieldOffset desc
in printf "bits[%d, %d)" (offset * bits) ((offset + 1) * bits))
-- (maybeBlockCode indent $ fieldStatements desc)
descToCode indent (DescUnion desc) = printf "%sunion %s@%d; # [%d, %d)\n" indent
(unionName desc) (unionNumber desc)
(maybeBlockCode indent $ unionStatements desc)
(unionTagOffset desc * 8) (unionTagOffset desc * 8 + 8)
-- (maybeBlockCode indent $ unionStatements desc)
descToCode indent (DescInterface desc) = printf "%sinterface %s%s" indent
(interfaceName desc)
(blockCode indent (interfaceStatements desc))
......
......@@ -44,6 +44,8 @@ data Token = Identifier String
| LiteralInt Integer
| LiteralFloat Double
| LiteralString String
| TrueKeyword
| FalseKeyword
| AtSign
| Colon
| Period
......
......@@ -23,11 +23,21 @@
module Util where
import Data.Char (isUpper, toUpper)
delimit _ [] = ""
delimit delimiter (h:t) = h ++ concatMap (delimiter ++) t
--delimit delimiter list = concat $ loop list where
-- loop ("":t) = loop t
-- loop (a:"":t) = loop (a:t)
-- loop (a:b:t) = a:delimiter:loop (b:t)
-- loop a = a
splitName :: String -> [String]
splitName (a:rest@(b:_)) | isUpper b = [a]:splitName rest
splitName (a:rest) = case splitName rest of
firstWord:moreWords -> (a:firstWord):moreWords
[] -> [[a]]
splitName [] = []
toTitleCase :: String -> String
toTitleCase (a:rest) = toUpper a:rest
toTitleCase [] = []
toUpperCaseWithUnderscores :: String -> String
toUpperCaseWithUnderscores name = delimit "_" $ map (map toUpper) $ splitName name
-- Copyright (c) 2013, Kenton Varda <temporal@gmail.com>
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--
-- 1. Redistributions of source code must retain the above copyright notice, this
-- list of conditions and the following disclaimer.
-- 2. Redistributions in binary form must reproduce the above copyright notice,
-- this list of conditions and the following disclaimer in the documentation
-- and/or other materials provided with the distribution.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
-- (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
-- LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
-- ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
module WireFormat where
import Data.List(sortBy, minimum)
import Data.Maybe(maybe)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Semantics
-- Is this field a non-retroactive member of a union? If so, its default value is not written.
isNonRetroUnionMember (FieldDesc {fieldNumber = n, fieldUnion = Just u}) = n > unionNumber u
isNonRetroUnionMember _ = False
-- What is this union's default tag value? If there is a retroactive field, it is that field's
-- number, otherwise it is the union's number (meaning no field set).
unionDefault desc = max (minimum $ map fieldNumber $ unionFields desc) (unionNumber desc)
encodeStruct desc assignments = result where
explicitlyAssignedNums = Set.fromList [fieldNumber desc | (desc, _) <- assignments]
explicitlyAssignedUnions = Set.fromList
[unionNumber u | (FieldDesc {fieldUnion = Just u}, _) <- assignments]
-- Was this field explicitly assigned, or was another member of the same union explicitly
-- assigned? If so, its default value is not written.
isExplicitlyAssigned (FieldDesc {fieldNumber = n, fieldUnion = u}) =
Set.member n explicitlyAssignedNums ||
maybe False (flip Set.member explicitlyAssignedUnions . unionNumber) u
-- Values explicitly assigned.
explicitValues = [(fieldOffset f, v) | (f, v) <- assignments]
-- Values from defaults.
defaultValues = [(o, v)
| field@(FieldDesc { fieldOffset = o, fieldDefaultValue = Just v}) <- structFields desc
, not $ isExplicitlyAssigned field
, not $ isNonRetroUnionMember field ]
-- Values of union tags.
unionValues = [(unionTagOffset u, UInt8Desc n)
| (FieldDesc {fieldUnion = Just u, fieldNumber = n}, _) <- assignments]
-- Default values of union dacs.
unionDefaultValues = [(unionTagOffset u, unionDefault u) | u <- structUnions desc
, not $ Set.member (unionNumber u) explicitlyAssignedUnions]
allValues = explicitValues ++ defaultValues ++ unionValues ++ unionDefaultValues
allData = [ (o * sizeInBits (fieldValueSize v)) v
| (o, v) <- allValues, fieldValueSize v /= SizeReference ]
allReferences = [ (o, v) | (o, v) <- allValues, fieldValueSize v == SizeReference ]
compareValues (o1, _) (o2, _) = compare o1 o2
sortedData = sortBy compareValues allData
sortedReferences = sortBy compareValues allReferences
result = encodeData sortedData ++ encodeReferences sortedReferences
// Generated code, DO NOT EDIT {{! unless you are editing the template, of course }}
#include <capnproto/wire-format.h>
#ifndef {{fileIncludeGuard}}
#define {{fileIncludeGuard}}
{{#fileNamespaces}}
namespace {{namespaceName}} {
{{/fileNamespaces}}
{{#fileStructs}}
struct {{structName}} {
class Reader;
class Builder;
{{#structChildren}}
struct {{structChildName}};
{{/structChildren}}
{{#structFields}}
{{#fieldDefaultBytes}}
static const ::capnproto::internal::AlignedData<{{defaultWordCount}}> DEFAULT_{{fieldUpperCase}};
{{/fieldDefaultBytes}}
{{/structFields}}
};
{{/fileStructs}}
{{#fileStructs}}
class {{structName}}::Reader {
public:
Reader() = default;
inline Reader(::capnproto::internal::StructReader base): _reader(base) {}
{{#structFields}}
// {{fieldDecl}}
{{#fieldIsPrimitive}}
inline {{fieldType}} get{{fieldTitleCase}}() {
return _reader.getDataField<{{fieldType}}>(
{{fieldOffset}} * ::capnproto::ELEMENTS, {{fieldDefaultValue}});
}
{{/fieldIsPrimitive}}
{{#fieldIsStruct}}
inline {{fieldType}}::Reader get{{fieldTitleCase}}() {
{{! TODO: Support per-field default values. }}
return {{fieldType}}::Reader(_reader.getStructField(
{{fieldOffset}} * ::capnproto::REFERENCES,
{{#fieldDefaultBytes}}DEFAULT_{{fieldUpperCase}}{{/fieldDefaultBytes}}
{{^fieldDefaultBytes}}{{fieldType}}::DEFAULT.words{{/fieldDefaultBytes}}));
}
{{/fieldIsStruct}}
{{#fieldIsList}}
inline {{fieldType}}::Reader get{{fieldTitleCase}}() {
return {{fieldType}}::Reader(_reader.getListField(
{{fieldOffset}} * ::capnproto::REFERENCES,
{{#fieldDefaultBytes}}DEFAULT_{{fieldUpperCase}}.words{{/fieldDefaultBytes}}
{{^fieldDefaultBytes}}nullptr{{/fieldDefaultBytes}}));
}
{{/fieldIsList}}
{{/structFields}}
private:
::capnproto::internal::StructReader _reader;
};
{{/fileStructs}}
{{#fileStructs}}
class {{structName}}::Builder {
public:
Builder() = default;
inline Builder(::capnproto::internal::StructBuilder base): _builder(base) {}
{{#structFields}}
// {{fieldDecl}}
{{#fieldDefaultBytes}}
static const ::capnproto::internal::AlignedData<{{defaultWordCount}}> DEFAULT_{{fieldUpperCase}};
{{/fieldDefaultBytes}}
{{#fieldIsPrimitive}}
inline {{fieldType}} get{{fieldTitleCase}}() {
return _builder.getDataField<{{fieldType}}>({{fieldOffset}} * ::capnproto::ELEMENTS);
}
inline void set{{fieldTitleCase}}({{fieldType}} value) {
return _builder.setDataField<{{fieldType}}>(
{{fieldOffset}} * ::capnproto::ELEMENTS, value);
}
{{/fieldIsPrimitive}}
{{#fieldIsStruct}}
inline {{fieldType}}::Builder init{{fieldTitleCase}}() {
return {{fieldType}}::Builder(_builder.initStructField(
{{fieldOffset}} * ::capnproto::REFERENCES, {{fieldType}}::DEFAULT.words));
}
inline {{fieldType}}::Builder get{{fieldTitleCase}}() {
{{! TODO: Support per-field default values. }}
return {{fieldType}}::Builder(_builder.getStructField(
{{fieldOffset}} * ::capnproto::REFERENCES,
{{#fieldDefaultBytes}}DEFAULT_{{fieldUpperCase}}{{/fieldDefaultBytes}}
{{^fieldDefaultBytes}}{{fieldType}}::DEFAULT.words{{/fieldDefaultBytes}}));
}
{{/fieldIsStruct}}
{{#fieldIsPrimitiveList}}
inline {{fieldType}}::Builder init{{fieldTitleCase}}(unsigned int size) {
return {{fieldType}}::Builder(_builder.initListField(
{{fieldOffset}} * ::capnproto::REFERENCES, ::capnproto::FieldSize::{{fieldElementSize}},
size * ::capnproto::ELEMENTS));
}
inline {{fieldType}}::Builder get{{fieldTitleCase}}() {
return {{fieldType}}::Builder(_builder.getListField(
{{fieldOffset}} * ::capnproto::REFERENCES,
{{#fieldDefaultBytes}}DEFAULT_{{fieldUpperCase}}.words{{/fieldDefaultBytes}}
{{^fieldDefaultBytes}}nullptr{{/fieldDefaultBytes}}));
}
{{/fieldIsPrimitiveList}}
{{#fieldIsStructList}}
inline {{fieldType}}::Builder init{{fieldTitleCase}}(unsigned int size) {
return {{fieldType}}::Builder(_builder.initStructListField(
{{fieldOffset}} * ::capnproto::REFERENCES, size * ::capnproto::ELEMENTS,
{{fieldType}}::DEFAULT.words));
}
inline {{fieldType}}::Builder get{{fieldTitleCase}}() {
return {{fieldType}}::Builder(_builder.getListField(
{{fieldOffset}} * ::capnproto::REFERENCES,
{{#fieldDefaultBytes}}DEFAULT_{{fieldUpperCase}}.words{{/fieldDefaultBytes}}
{{^fieldDefaultBytes}}nullptr{{/fieldDefaultBytes}}));
}
{{/fieldIsStructList}}
{{/structFields}}
private:
::capnproto::internal::StructBuilder _builder;
};
{{/fileStructs}}
{{#fileNamespaces}}
} // namespace
{{/fileNamespaces}}
#endif // {{fileIncludeGuard}}
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment