tock-mirror/common/EvalLiterals.hs

{-
Tock: a compiler for parallel languages
Copyright (C) 2007  University of Kent

This program 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 2 of the License, or (at your
option) any later version.

This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.
-}

-- | Evaluate simple literal expressions.
module EvalLiterals where

import Control.Monad.Error
import Control.Monad.Identity
import Control.Monad.State
import Data.Char
import Data.Generics
import Data.Int
import Data.Maybe
import Data.Word
import Numeric

import qualified AST as A
import CompState hiding (CSM) -- everything here is read-only
import Errors
import Metadata
import Traversal
import TypeSizes

type EvalM = ErrorT ErrorReport (StateT CompState Identity)

instance Die EvalM where
  dieReport = throwError

-- | Evaluated values of various types.
data OccValue =
  OccBool Bool
  | OccByte Word8
  | OccUInt16 Word16
  | OccUInt32 Word32
  | OccUInt64 Word64
  | OccInt8 Int8
  | OccInt16 Int16
  | OccInt CIntReplacement
  | OccInt32 Int32
  | OccInt64 Int64
  | OccReal32 Float
  | OccReal64 Double
  | OccArray [OccValue]
  | OccRecord A.Name [OccValue]
  deriving (Show, Eq, Typeable, Data)

-- | Is an expression a constant literal?
isConstant :: A.Expression -> Bool
isConstant (A.Literal _ _ (A.ArrayListLiteral _ aes))
    = isConstantStruct aes
isConstant (A.Literal _ _ (A.RecordLiteral _ es))
    = and $ map isConstant es
isConstant (A.Literal _ _ _) = True
isConstant (A.True _) = True
isConstant (A.False _) = True
isConstant _ = False

-- | Is an array literal element constant?
isConstantStruct :: A.Structured A.Expression -> Bool
isConstantStruct (A.Several _ ss) = and $ map isConstantStruct ss
isConstantStruct (A.Only _ e) = isConstant e
isConstantStruct (A.ProcThen {}) = False
isConstantStruct (A.Spec {}) = False

-- | Evaluate a byte literal.
evalByte :: (CSMR m, Die m) => Meta -> String -> m Char
evalByte m s
    =  do ps <- getCompState
          case runEvaluator ps (evalByteLiteral m OccByte s) of
            Left (m', err) ->
              dieReport (m', "Cannot evaluate byte literal: " ++ err)
            Right (OccByte ch) ->
              return (chr $ fromIntegral ch)

-- | Run an evaluator operation.
runEvaluator :: CompState -> EvalM OccValue -> Either ErrorReport OccValue
runEvaluator ps func
    = runIdentity (evalStateT (runErrorT func) ps)

-- | Evaluate a simple literal expression.
evalSimpleExpression :: A.Expression -> EvalM OccValue
evalSimpleExpression e@(A.Literal _ _ _) = evalSimpleLiteral e
evalSimpleExpression e = throwError (Just $ findMeta e, "Not a literal")

-- | Turn the result of one of the read* functions into an OccValue,
-- or throw an error if it didn't parse.
fromRead :: Meta -> (a -> OccValue) -> (String -> [(a, String)])
            -> String -> EvalM OccValue
fromRead m cons reader s
    = case reader s of
        [(v, "")] -> return $ cons v
        _ -> throwError (Just m, "Cannot parse literal: " ++ s)

-- | Evaluate a simple (non-array) literal.
evalSimpleLiteral :: A.Expression -> EvalM OccValue
evalSimpleLiteral (A.Literal m t lr)
    = underlyingType m t >>= \t' -> 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
        A.Real32 -> intoF OccReal32
        A.Real64 -> intoF OccReal64
        _        -> 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
            A.RealLiteral _ s -> fromRead m OccReal32 readFloat' s
            _                 -> bad

    into :: (Num t, Real t) => (t -> OccValue) -> EvalM OccValue
    into cons
        = case lr of
            A.ByteLiteral _ s -> evalByteLiteral m cons s
            A.IntLiteral _ s  -> fromRead m cons (readSigned readDec) s
            A.HexLiteral _ s  -> fromRead m cons readHex s
            _                 -> bad

    intoF :: RealFrac t => (t -> OccValue) -> EvalM OccValue
    intoF cons
        = case lr of
            A.ByteLiteral _ s -> evalByteLiteral m cons s
            A.IntLiteral _ s  -> fromRead m cons (readSigned readDec) s
            A.HexLiteral _ s  -> fromRead m cons readHex s
            A.RealLiteral _ s -> fromRead m cons readFloat' s
            _                 -> bad

    -- readFloat only handles unsigned values, so we need to look out for the negation
    -- ourselves:
    readFloat' :: RealFrac a => ReadS a
    readFloat' [] = []
    readFloat' ('-':rest) = [(negate x, s) | (x, s) <- readFloat rest]
    readFloat' s = readFloat s


    bad :: EvalM OccValue
    bad = throwError (Just m, "Cannot evaluate literal")

    m = findMeta lr

-- | Evaluate a byte literal.
evalByteLiteral :: Num t => Meta -> (t -> OccValue) -> String -> EvalM OccValue
evalByteLiteral m cons ('*':'#':hex)
    = do OccInt n <- fromRead m OccInt readHex hex
         return $ cons (fromIntegral n)
evalByteLiteral _ cons ['*', ch]
    = return $ cons (fromIntegral $ ord $ star ch)
  where
    star :: Char -> Char
    star 'c' = '\r'
    star 'n' = '\n'
    star 't' = '\t'
    star 's' = ' '
    star c = c
evalByteLiteral _ cons [ch]
    = return $ cons (fromIntegral $ ord ch)
evalByteLiteral m _ _ = throwError (Just m, "Bad BYTE literal")

-- | Resolve a datatype into its underlying type -- i.e. if it's a named data
-- type, then return the underlying real type. This will recurse.
underlyingType :: forall m. (CSMR m, Die m) => Meta -> A.Type -> m A.Type
underlyingType m = applyTopDownM (resolveUserType m)
    -- After resolving a user type, we have to recurse
    -- on the resulting type, so we must use a top-down transformation.

-- | Like underlyingType, but only do the "outer layer": if you give this a
-- user type that's an array of user types, then you'll get back an array of
-- user types.
resolveUserType :: (CSMR m, Die m) => Meta -> A.Type -> m A.Type
resolveUserType m (A.UserDataType n)
    =  do st <- specTypeOfName n
          case st of
            A.DataType _ t -> resolveUserType m t
            _ -> dieP m $ "Not a type name: " ++ show n
resolveUserType _ t = return t