suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Clean up EvalLiterals.

Browse Source 
In particular, evalSimpleLiteral is now much nicer, and the error
messages should be a bit more comprehensible.

The signed types previously used a different version of fromRead that
passed an extra argument that it then didn't use; I've switched back to
the old version now, since it appears not to need it any more.
This commit is contained in:
Adam Sampson 2008-04-08 00:29:23 +00:00
parent f1e9ffe230
commit 9e9459cb4a
2 changed files with 57 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
backends/GenerateC.hs
View File

@ -510,8 +510,8 @@ cgenLiteral lr t
= if isStringLiteral lr = if isStringLiteral lr
then do tell ["\""] then do tell ["\""]
let A.ArrayLiteral _ aes = lr let A.ArrayLiteral _ aes = lr
sequence_ [genByteLiteral s sequence_ [genByteLiteral m s
| A.ArrayElemExpr (A.Literal _ _ (A.ByteLiteral _ s)) <- aes] | A.ArrayElemExpr (A.Literal _ _ (A.ByteLiteral m s)) <- aes]
tell ["\""] tell ["\""]
else call genLiteralRepr lr t else call genLiteralRepr lr t
@ -554,7 +554,8 @@ cgenLiteralRepr (A.HexLiteral m s) t
tell ["((",ct,")0x", s] tell ["((",ct,")0x", s]
genLitSuffix t genLitSuffix t
tell [")"] tell [")"]
cgenLiteralRepr (A.ByteLiteral m s) _ = tell ["'"] >> genByteLiteral s >> tell ["'"] cgenLiteralRepr (A.ByteLiteral m s) _
= tell ["'"] >> genByteLiteral m s >> tell ["'"]
cgenLiteralRepr (A.ArrayLiteral m aes) _ cgenLiteralRepr (A.ArrayLiteral m aes) _
= do genLeftB = do genLeftB
call genArrayLiteralElems aes call genArrayLiteralElems aes
@ -623,9 +624,9 @@ cgenArrayLiteralElems aes
genElem (A.ArrayElemArray aes) = call genArrayLiteralElems aes genElem (A.ArrayElemArray aes) = call genArrayLiteralElems aes
genElem (A.ArrayElemExpr e) = call genUnfoldedExpression e genElem (A.ArrayElemExpr e) = call genUnfoldedExpression e
genByteLiteral :: String -> CGen () genByteLiteral :: Meta -> String -> CGen ()
genByteLiteral s genByteLiteral m s
= do c <- evalByte s = do c <- evalByte m s
tell [convByte c] tell [convByte c]
convByte :: Char -> String convByte :: Char -> String

141
common/EvalLiterals.hs
View File

@ -51,8 +51,6 @@ data OccValue =
| OccInt Int32 | OccInt Int32
| OccInt32 Int32 | OccInt32 Int32
| OccInt64 Int64 | OccInt64 Int64
-- FIXME This should include the type of the elements, so we can handle
-- empty arrays.
| OccArray [OccValue] | OccArray [OccValue]
| OccRecord A.Name [OccValue] | OccRecord A.Name [OccValue]
deriving (Show, Eq, Typeable, Data) deriving (Show, Eq, Typeable, Data)
@ -74,12 +72,14 @@ isConstantArray (A.ArrayElemArray aes) = and $ map isConstantArray aes
isConstantArray (A.ArrayElemExpr e) = isConstant e isConstantArray (A.ArrayElemExpr e) = isConstant e
-- | Evaluate a byte literal. -- | Evaluate a byte literal.
evalByte :: (CSMR m, Die m) => String -> m Char evalByte :: (CSMR m, Die m) => Meta -> String -> m Char
evalByte s evalByte m s
= do ps <- getCompState = do ps <- getCompState
case runEvaluator ps (evalByteLiteral OccByte s) of case runEvaluator ps (evalByteLiteral m OccByte s) of
Left (m,err) -> dieReport (m,"cannot evaluate byte literal: " ++ err) Left (m', err) ->
Right (OccByte ch) -> return (chr $ fromIntegral ch) dieReport (m', "Cannot evaluate byte literal: " ++ err)
Right (OccByte ch) ->
return (chr $ fromIntegral ch)
-- | Run an evaluator operation. -- | Run an evaluator operation.
runEvaluator :: CompState -> EvalM OccValue -> Either ErrorReport OccValue runEvaluator :: CompState -> EvalM OccValue -> Either ErrorReport OccValue
@ -89,101 +89,60 @@ runEvaluator ps func
-- | Evaluate a simple literal expression. -- | Evaluate a simple literal expression.
evalSimpleExpression :: A.Expression -> EvalM OccValue evalSimpleExpression :: A.Expression -> EvalM OccValue
evalSimpleExpression e@(A.Literal _ _ _) = evalSimpleLiteral e evalSimpleExpression e@(A.Literal _ _ _) = evalSimpleLiteral e
evalSimpleExpression e = throwError (Just $ findMeta e,"not a literal") evalSimpleExpression e = throwError (Just $ findMeta e, "Not a literal")
-- | Turn the result of one of the read* functions into an OccValue, -- | Turn the result of one of the read* functions into an OccValue,
-- or throw an error if it didn't parse. -- or throw an error if it didn't parse.
fromRead' :: (a -> t) -> (a -> OccValue) -> (t -> OccValue) -> (String -> [(a, String)]) -> String -> EvalM OccValue fromRead :: Meta -> (a -> OccValue) -> (String -> [(a, String)])
fromRead' mod _ cons reader s -> String -> EvalM OccValue
fromRead m cons reader s
= case reader s of = case reader s of
[(v, "")] -> return $ cons (mod v) [(v, "")] -> return $ cons v
_ -> throwError (Nothing,"cannot parse literal: " ++ s) _ -> throwError (Just m, "Cannot parse literal: " ++ s)
fromRead :: (t -> OccValue) -> (String -> [(t, String)]) -> String -> EvalM OccValue
fromRead = fromRead' id undefined
-- | Evaluate a simple (non-array) literal. -- | Evaluate a simple (non-array) literal.
evalSimpleLiteral :: A.Expression -> EvalM OccValue evalSimpleLiteral :: A.Expression -> EvalM OccValue
evalSimpleLiteral (A.Literal _ t lr)
= case t of
A.Infer -> defaults
A.Byte -> into OccByte
A.UInt16 -> into OccUInt16
A.UInt32 -> into OccUInt32
A.UInt64 -> into OccUInt64
A.Int8 -> into OccInt8
A.Int16 -> into OccInt16
A.Int -> into OccInt
A.Int32 -> into OccInt32
A.Int64 -> into OccInt64
_ -> bad
where
defaults :: EvalM OccValue
defaults
= case lr of
A.ByteLiteral _ s -> evalByteLiteral m OccByte s
A.IntLiteral _ s -> fromRead m OccInt (readSigned readDec) s
A.HexLiteral _ s -> fromRead m OccInt readHex s
_ -> bad
-- If the type hasn't yet been inferred, we use the default type. into :: (Num t, Real t) => (t -> OccValue) -> EvalM OccValue
evalSimpleLiteral (A.Literal _ A.Infer (A.ByteLiteral _ s)) into cons
= evalByteLiteral OccByte s = case lr of
evalSimpleLiteral (A.Literal _ A.Infer (A.IntLiteral _ s)) A.ByteLiteral _ s -> evalByteLiteral m cons s
= fromRead OccInt (readSigned readDec) s A.IntLiteral _ s -> fromRead m cons (readSigned readDec) s
evalSimpleLiteral (A.Literal _ A.Infer (A.HexLiteral _ s)) A.HexLiteral _ s -> fromRead m cons readHex s
= fromRead OccInt readHex s _ -> bad
evalSimpleLiteral (A.Literal _ A.Byte (A.ByteLiteral _ s)) bad :: EvalM OccValue
= evalByteLiteral OccByte s bad = throwError (Just m, "Cannot evaluate literal")
evalSimpleLiteral (A.Literal _ A.Byte (A.IntLiteral _ s))
= fromRead OccByte (readSigned readDec) s
evalSimpleLiteral (A.Literal _ A.Byte (A.HexLiteral _ s))
= fromRead OccByte readHex s
evalSimpleLiteral (A.Literal _ A.UInt16 (A.ByteLiteral _ s)) m = findMeta lr
= evalByteLiteral OccUInt16 s
evalSimpleLiteral (A.Literal _ A.UInt16 (A.IntLiteral _ s))
= fromRead OccUInt16 (readSigned readDec) s
evalSimpleLiteral (A.Literal _ A.UInt16 (A.HexLiteral _ s))
= fromRead OccUInt16 readHex s
evalSimpleLiteral (A.Literal _ A.UInt32 (A.ByteLiteral _ s))
= evalByteLiteral OccUInt32 s
evalSimpleLiteral (A.Literal _ A.UInt32 (A.IntLiteral _ s))
= fromRead OccUInt32 (readSigned readDec) s
evalSimpleLiteral (A.Literal _ A.UInt32 (A.HexLiteral _ s))
= fromRead OccUInt32 readHex s
evalSimpleLiteral (A.Literal _ A.UInt64 (A.ByteLiteral _ s))
= evalByteLiteral OccUInt64 s
evalSimpleLiteral (A.Literal _ A.UInt64 (A.IntLiteral _ s))
= fromRead OccUInt64 (readSigned readDec) s
evalSimpleLiteral (A.Literal _ A.UInt64 (A.HexLiteral _ s))
= fromRead OccUInt64 readHex s
evalSimpleLiteral (A.Literal _ A.Int8 (A.ByteLiteral _ s))
= evalByteLiteral OccInt8 s
evalSimpleLiteral (A.Literal _ A.Int8 (A.IntLiteral _ s))
= fromRead OccInt8 (readSigned readDec) s
evalSimpleLiteral (A.Literal _ A.Int8 (A.HexLiteral _ s))
= fromRead' (fromInteger . toInteger) OccByte OccInt8 readHex s
evalSimpleLiteral (A.Literal _ A.Int (A.ByteLiteral _ s))
= evalByteLiteral OccInt s
evalSimpleLiteral (A.Literal _ A.Int (A.IntLiteral _ s))
= fromRead OccInt (readSigned readDec) s
evalSimpleLiteral (A.Literal _ A.Int (A.HexLiteral _ s))
= fromRead' (fromInteger . toInteger) OccUInt32 OccInt readHex s
evalSimpleLiteral (A.Literal _ A.Int16 (A.ByteLiteral _ s))
= evalByteLiteral OccInt16 s
evalSimpleLiteral (A.Literal _ A.Int16 (A.IntLiteral _ s))
= fromRead OccInt16 (readSigned readDec) s
evalSimpleLiteral (A.Literal _ A.Int16 (A.HexLiteral _ s))
= fromRead' (fromInteger . toInteger) OccUInt16 OccInt16 readHex s
evalSimpleLiteral (A.Literal _ A.Int32 (A.ByteLiteral _ s))
= evalByteLiteral OccInt32 s
evalSimpleLiteral (A.Literal _ A.Int32 (A.IntLiteral _ s))
= fromRead OccInt32 (readSigned readDec) s
evalSimpleLiteral (A.Literal _ A.Int32 (A.HexLiteral _ s))
= fromRead' (fromInteger . toInteger) OccUInt32 OccInt32 readHex s
evalSimpleLiteral (A.Literal _ A.Int64 (A.ByteLiteral _ s))
= evalByteLiteral OccInt64 s
evalSimpleLiteral (A.Literal _ A.Int64 (A.IntLiteral _ s))
= fromRead OccInt64 (readSigned readDec) s
evalSimpleLiteral (A.Literal _ A.Int64 (A.HexLiteral _ s))
= fromRead' (fromInteger . toInteger) OccUInt64 OccInt64 readHex s
evalSimpleLiteral l = throwError (Just $ findMeta l,"bad literal: " ++ show l)
-- | Evaluate a byte literal. -- | Evaluate a byte literal.
evalByteLiteral :: Num t => (t -> OccValue) -> String -> EvalM OccValue evalByteLiteral :: Num t => Meta -> (t -> OccValue) -> String -> EvalM OccValue
evalByteLiteral cons ('*':'#':hex) evalByteLiteral m cons ('*':'#':hex)
= do OccInt n <- fromRead OccInt readHex hex = do OccInt n <- fromRead m OccInt readHex hex
return $ cons (fromIntegral n) return $ cons (fromIntegral n)
evalByteLiteral cons ['*', ch] evalByteLiteral _ cons ['*', ch]
= return $ cons (fromIntegral $ ord $ star ch) = return $ cons (fromIntegral $ ord $ star ch)
where where
star :: Char -> Char star :: Char -> Char
@ -192,6 +151,6 @@ evalByteLiteral cons ['*', ch]
star 't' = '\t' star 't' = '\t'
star 's' = ' ' star 's' = ' '
star c = c star c = c
evalByteLiteral cons [ch] evalByteLiteral _ cons [ch]
= return $ cons (fromIntegral $ ord ch) = return $ cons (fromIntegral $ ord ch)
evalByteLiteral _ _ = throwError (Nothing,"bad BYTE literal") evalByteLiteral m _ _ = throwError (Just m, "Bad BYTE literal")