module Language.Fortran.Vars.BozConstant
  ( resolveBozConstant
  , bozToInt
  , bozToInt1
  , bozToInt2
  , bozToInt4
  , bozToInt8
  )
where

import qualified Data.Map                      as M

import qualified Language.Fortran.AST.Literal.Boz as AST
import           Language.Fortran.Vars.Types    ( SymbolTableEntry(..)
                                                , SemType(..)
                                                , Kind
                                                , ExpVal(..)
                                                , SymbolTable
                                                )

import Data.Int

-- | Given 'SymbolTable', contextual symbol name and BOZ Constant
-- ('ExpVal' constructed with Boz String), resolve BOZ Constant considering
-- contextual symbol.
--
-- Currently, it only resolves BOZ Constants in context of INTEGER.
resolveBozConstant :: SymbolTable -> String -> ExpVal -> ExpVal
resolveBozConstant :: SymbolTable -> String -> ExpVal -> ExpVal
resolveBozConstant SymbolTable
symTable String
assignSymbol (Boz Boz
b) = Boz -> ExpVal
go Boz
b
  where
    go :: Boz -> ExpVal
go Boz
boz = case Maybe SymbolTableEntry
entry of
      Just (SVariable (TInteger Int
kind) Location
_) ->
        Int -> Boz -> ExpVal
bozToInt Int
kind Boz
boz
      Just (SVariable Type
ty Location
_) ->
        forall a. HasCallStack => String -> a
error
          forall a b. (a -> b) -> a -> b
$  String
assignSymbol
          forall a. Semigroup a => a -> a -> a
<> String
" is a "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Type
ty
          forall a. Semigroup a => a -> a -> a
<> String
"\nBOZ constants can only be resolved in an INTEGER context"
      Just SymbolTableEntry
_ -> forall a. HasCallStack => String -> a
error
        (String
assignSymbol
        forall a. [a] -> [a] -> [a]
++ String
" is not a scalar variable. \
                                          \Invalid fortran sytax"
        )
      Maybe SymbolTableEntry
Nothing -> forall a. HasCallStack => String -> a
error
        (String
assignSymbol
        forall a. [a] -> [a] -> [a]
++ String
" could not be found. \
                                          \Invalid fortran syntax"
        )
    entry :: Maybe SymbolTableEntry
entry = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
assignSymbol SymbolTable
symTable

resolveBozConstant SymbolTable
_ String
_ ExpVal
_ = forall a. HasCallStack => String -> a
error String
"Can only resolve ExpVal Boz"

-- | Resolve a BOZ constant as an INTEGER(k).
--
-- Works on arbitrary kinds, including non-standard, assuming that kind
-- indicates size in bytes.
bozToInt :: Kind -> AST.Boz -> ExpVal
bozToInt :: Int -> Boz -> ExpVal
bozToInt Int
kind Boz
boz = case Int
kind of
  -- handle regular kinds via bitwise operations on sized machine integers,
  -- relying on overflow behaviour
  Int
1 -> Boz -> ExpVal
bozToInt1 Boz
boz
  Int
2 -> Boz -> ExpVal
bozToInt2 Boz
boz
  Int
4 -> Boz -> ExpVal
bozToInt4 Boz
boz
  Int
8 -> Boz -> ExpVal
bozToInt8 Boz
boz

  -- handle irregular kinds via explicit numeric operations
  -- (shouldn't really ever trigger, but no harm)
  Int
k -> Boz -> Int -> ExpVal
bozAsTwosCompExplicit Boz
boz Int
k

--------------------------------------------------------------------------------

-- | Resolve a BOZ constant as an INTEGER(1).
bozToInt1 :: AST.Boz -> ExpVal
bozToInt1 :: Boz -> ExpVal
bozToInt1 = Int -> ExpVal
Int forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Num a, Eq a, FiniteBits a) => Boz -> a
AST.bozAsTwosComp @Int8

-- | Resolve a BOZ constant as an INTEGER(2).
bozToInt2 :: AST.Boz -> ExpVal
bozToInt2 :: Boz -> ExpVal
bozToInt2 = Int -> ExpVal
Int forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Num a, Eq a, FiniteBits a) => Boz -> a
AST.bozAsTwosComp @Int16

-- | Resolve a BOZ constant as an INTEGER(4).
bozToInt4 :: AST.Boz -> ExpVal
bozToInt4 :: Boz -> ExpVal
bozToInt4 = Int -> ExpVal
Int forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Num a, Eq a, FiniteBits a) => Boz -> a
AST.bozAsTwosComp @Int32

-- | Resolve a BOZ constant as an INTEGER(8).
bozToInt8 :: AST.Boz -> ExpVal
bozToInt8 :: Boz -> ExpVal
bozToInt8 = Int -> ExpVal
Int forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Num a, Eq a, FiniteBits a) => Boz -> a
AST.bozAsTwosComp @Int64

--------------------------------------------------------------------------------

bozAsTwosCompExplicit :: AST.Boz -> Kind -> ExpVal
bozAsTwosCompExplicit :: Boz -> Int -> ExpVal
bozAsTwosCompExplicit Boz
boz Int
kind =
  let allowedBinaryLength :: Int
allowedBinaryLength = Int
kind forall a. Num a => a -> a -> a
* Int
8
      maxBinaryValue :: Int
maxBinaryValue      = Int
2 forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
allowedBinaryLength forall a. Num a => a -> a -> a
- Int
1) forall a. Num a => a -> a -> a
- Int
1
      minBinaryValue :: Int
minBinaryValue      = (-Int
1) forall a. Num a => a -> a -> a
* Int
2 forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
allowedBinaryLength forall a. Num a => a -> a -> a
- Int
1)
      decimal :: Int
decimal             = forall a. (Num a, Eq a) => Boz -> a
AST.bozAsNatural Boz
boz
      overflow :: Int
overflow            = Int
decimal forall a. Num a => a -> a -> a
- Int
maxBinaryValue
  in  if Int
overflow forall a. Ord a => a -> a -> Bool
> Int
0 then Int -> ExpVal
Int (Int
minBinaryValue forall a. Num a => a -> a -> a
+ Int
overflow forall a. Num a => a -> a -> a
- Int
1) else Int -> ExpVal
Int Int
decimal