module Language.Fortran.Vars.BozConstant
( resolveBozConstant
, bozToInt
, bozToInt2
, bozToInt4
, bozToInt8
)
where
import Data.Char ( digitToInt
, intToDigit
, toLower
)
import qualified Data.Map as M
import Numeric ( readInt
, showIntAtBase
)
import Text.Read ( ReadS )
import Language.Fortran.Vars.Types
( SymbolTableEntry(..)
, Type(..)
, SemType(..)
, Kind
, ExpVal(..)
, SymbolTable
)
data BozDecomposed = BozDecomposed String String Char Int String
deriving Int -> BozDecomposed -> ShowS
[BozDecomposed] -> ShowS
BozDecomposed -> String
(Int -> BozDecomposed -> ShowS)
-> (BozDecomposed -> String)
-> ([BozDecomposed] -> ShowS)
-> Show BozDecomposed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BozDecomposed] -> ShowS
$cshowList :: [BozDecomposed] -> ShowS
show :: BozDecomposed -> String
$cshow :: BozDecomposed -> String
showsPrec :: Int -> BozDecomposed -> ShowS
$cshowsPrec :: Int -> BozDecomposed -> ShowS
Show
parseBozDecomposed :: ExpVal -> BozDecomposed
parseBozDecomposed :: ExpVal -> BozDecomposed
parseBozDecomposed (Boz String
bozStr) = String -> String -> Char -> Int -> String -> BozDecomposed
BozDecomposed String
bozStr
String
digits
Char
numsysChar
Int
numsysInt
String
binary
where
digits :: String
digits = ShowS
getDigits String
bozStr
numsysChar :: Char
numsysChar = if String -> Char
forall a. [a] -> a
head String
bozStr Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"boxz" then String -> Char
forall a. [a] -> a
head String
bozStr else String -> Char
forall a. [a] -> a
last String
bozStr
numsysInt :: Int
numsysInt = case Char
numsysChar of
Char
'b' -> Int
2
Char
'o' -> Int
8
Char
'x' -> Int
16
Char
'z' -> Int
16
Char
_ -> String -> Int
forall a. HasCallStack => String -> a
error
(Char
numsysChar
Char -> ShowS
forall a. a -> [a] -> [a]
: String
" is not supported BOZ specifier.\
\ Invalid fortran syntax"
)
binary :: String
binary = String -> Int -> String
toBinaryString String
digits Int
numsysInt
parseBozDecomposed ExpVal
_ = String -> BozDecomposed
forall a. HasCallStack => String -> a
error String
"ExpVal is not a BOZ constant"
resolveBozConstant' :: SymbolTable -> String -> BozDecomposed -> ExpVal
resolveBozConstant' :: SymbolTable -> String -> BozDecomposed -> ExpVal
resolveBozConstant' SymbolTable
symTable String
assignSymbol BozDecomposed
bozDecomposed =
let entry :: Maybe SymbolTableEntry
entry = String -> SymbolTable -> Maybe SymbolTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
assignSymbol SymbolTable
symTable
in
case Maybe SymbolTableEntry
entry of
Just (SVariable (TInteger Int
kind) Location
_) ->
BozDecomposed -> Int -> ExpVal
resolveBozConstantInContext BozDecomposed
bozDecomposed Int
kind
Just (SVariable SemType
ty Location
_) ->
String -> ExpVal
forall a. HasCallStack => String -> a
error
(String -> ExpVal) -> String -> ExpVal
forall a b. (a -> b) -> a -> b
$ String
assignSymbol
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is a "
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SemType -> String
forall a. Show a => a -> String
show SemType
ty
String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\nBOZ constants can only be resolved in an INTEGER context"
Just SymbolTableEntry
_ -> String -> ExpVal
forall a. HasCallStack => String -> a
error
(String
assignSymbol
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not a scalar variable. \
\Invalid fortran sytax"
)
Maybe SymbolTableEntry
Nothing -> String -> ExpVal
forall a. HasCallStack => String -> a
error
(String
assignSymbol
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" could not be found. \
\Invalid fortran syntax"
)
resolveBozConstantInContext :: BozDecomposed -> Kind -> ExpVal
resolveBozConstantInContext :: BozDecomposed -> Int -> ExpVal
resolveBozConstantInContext (BozDecomposed String
_ String
_ Char
_ Int
_ String
binary) Int
kind =
let allowedBinaryLength :: Int
allowedBinaryLength = Int
kind Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8
maxBinaryValue :: Int
maxBinaryValue = Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
allowedBinaryLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
minBinaryValue :: Int
minBinaryValue = (-Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
allowedBinaryLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
truncatedBinary :: String
truncatedBinary = ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
allowedBinaryLength ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
binary
decimal :: Int
decimal = String -> Int -> Int
numsysStringToDecimal String
truncatedBinary Int
2
overflow :: Int
overflow = Int
decimal Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
maxBinaryValue
in if Int
overflow Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Int -> ExpVal
Int (Int
minBinaryValue Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
overflow Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) else Int -> ExpVal
Int Int
decimal
getDigits :: String -> String
getDigits :: ShowS
getDigits String
bozStr = [ Char -> Char
toLower Char
c | Char
c <- String
digits ]
where
digits :: String
digits =
(Char -> ShowS) -> String -> ShowS
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Char
l String
acc -> if Char
l Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"'boxz" then String
acc else Char
l Char -> ShowS
forall a. a -> [a] -> [a]
: String
acc) [] String
bozStr
toBinaryString :: String -> Int -> String
toBinaryString :: String -> Int -> String
toBinaryString String
digits Int
fromNumsys = Int -> String
decimalToBinaryString Int
decimal
where decimal :: Int
decimal = String -> Int -> Int
numsysStringToDecimal String
digits Int
fromNumsys
numsysStringToDecimal :: String -> Int -> Int
numsysStringToDecimal :: String -> Int -> Int
numsysStringToDecimal String
digits Int
numsys = Int
decimal
where
numsysValidFunction :: Char -> Bool
numsysValidFunction = (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
intToDigit [Int
0 .. (Int
numsys Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)])
numsysReader :: ReadS Int
numsysReader = Int -> (Char -> Bool) -> (Char -> Int) -> ReadS Int
forall a. Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
readInt Int
numsys Char -> Bool
numsysValidFunction Char -> Int
digitToInt :: ReadS Int
((Int
decimal, String
_) : [(Int, String)]
_) = ReadS Int
numsysReader String
digits
decimalToBinaryString :: Int -> String
decimalToBinaryString :: Int -> String
decimalToBinaryString Int
decimal = Int -> (Int -> Char) -> Int -> ShowS
forall a. (Integral a, Show a) => a -> (Int -> Char) -> a -> ShowS
showIntAtBase Int
2 Int -> Char
intToDigit Int
decimal String
""
resolveBozConstant :: SymbolTable -> String -> ExpVal -> ExpVal
resolveBozConstant :: SymbolTable -> String -> ExpVal -> ExpVal
resolveBozConstant SymbolTable
symTable String
assignSymbol boz :: ExpVal
boz@(Boz String
_) =
SymbolTable -> String -> BozDecomposed -> ExpVal
resolveBozConstant' SymbolTable
symTable String
assignSymbol (ExpVal -> BozDecomposed
parseBozDecomposed ExpVal
boz)
resolveBozConstant SymbolTable
_ String
_ ExpVal
_ = String -> ExpVal
forall a. HasCallStack => String -> a
error String
"Can only resolve ExpVal Boz"
bozToInt :: Int -> ExpVal -> ExpVal
bozToInt :: Int -> ExpVal -> ExpVal
bozToInt Int
kind ExpVal
boz = BozDecomposed -> Int -> ExpVal
resolveBozConstantInContext (ExpVal -> BozDecomposed
parseBozDecomposed ExpVal
boz) Int
kind
bozToInt2 :: ExpVal -> ExpVal
bozToInt2 :: ExpVal -> ExpVal
bozToInt2 = Int -> ExpVal -> ExpVal
bozToInt Int
2
bozToInt4 :: ExpVal -> ExpVal
bozToInt4 :: ExpVal -> ExpVal
bozToInt4 = Int -> ExpVal -> ExpVal
bozToInt Int
4
bozToInt8 :: ExpVal -> ExpVal
bozToInt8 :: ExpVal -> ExpVal
bozToInt8 = Int -> ExpVal -> ExpVal
bozToInt Int
8