3a_asm/Expr_eval.hs

   1 {-   `Deep Thought', a softcore CPU implemented on a FPGA
   2
   3     Copyright (C) 2010 Markus Hofstaetter <markus.manrow@gmx.at>
   4     Copyright (C) 2010 Martin Perner <e0725782@student.tuwien.ac.at>
   5     Copyright (C) 2010 Stefan Rebernig <stefan.rebernig@gmail.com>
   6     Copyright (C) 2010 Manfred Schwarz <e0725898@student.tuwien.ac.at>
   7     Copyright (C) 2010 Bernhard Urban <lewurm@gmail.com>
   8
   9     This program is free software: you can redistribute it and/or modify
  10     it under the terms of the GNU General Public License as published by
  11     the Free Software Foundation, either version 3 of the License, or
  12     (at your option) any later version.
  13
  14     This program is distributed in the hope that it will be useful,
  15     but WITHOUT ANY WARRANTY; without even the implied warranty of
  16     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17     GNU General Public License for more details.
  18
  19     You should have received a copy of the GNU General Public License
  20     along with this program.  If not, see <http://www.gnu.org/licenses/>. -}
  21
  22 module Expr_eval (expr, testExpr) where
  23
  24 import DTFormat
  25
  26 import Text.Printf
  27 import Text.Parsec.String
  28 import Text.ParserCombinators.Parsec
  29 import Text.ParserCombinators.Parsec.Expr
  30 import qualified Text.ParserCombinators.Parsec.Token as P
  31 import Text.ParserCombinators.Parsec.Language
  32 import System.IO
  33 import Data.Word
  34 import Data.List
  35 import Data.Bits
  36
  37 lexer :: P.TokenParser ()
  38 lexer = P.makeTokenParser (haskellDef { reservedOpNames = ["*","/","+","-","<<",">>","^"] })
  39
  40 decimal = P.decimal lexer
  41 hexadecimal = P.hexadecimal lexer
  42 reservedOp = P.reservedOp lexer
  43
  44 expr :: [DictElem] -> Parser Word32
  45 expr d = buildExpressionParser table (factor_spaces d) <?> "expression"
  46         where
  47         table = [
  48                 [unary "-" negate, unary "+" id],
  49                 [op "<<" myShiftL AssocLeft, op ">>" myShiftR AssocLeft],
  50                 [op "*" (*) AssocLeft, op "/" div AssocLeft],
  51                 [op "^" xor AssocLeft],
  52                 [op "+" (+) AssocLeft, op "-" (-) AssocLeft]
  53                 ]
  54         op s f assoc = Infix (do{ reservedOp s; return f } <?> "operator") assoc
  55         unary s f = Prefix (do{ reservedOp s; return f })
  56
  57 myShiftL :: Word32 -> Word32 -> Word32
  58 myShiftL b x = shiftL b (fromInteger $ toInteger x)
  59 myShiftR :: Word32 -> Word32 -> Word32
  60 myShiftR b x = shiftR b (fromInteger $ toInteger x)
  61
  62 factor_spaces :: [DictElem] -> Parser Word32
  63 factor_spaces d = do
  64         parseMySpaces
  65         r <- factor d
  66         parseMySpaces
  67         return r
  68
  69 factor :: [DictElem] -> Parser Word32
  70 factor d =
  71         do {
  72                 char '('; r <- expr d; char ')';
  73                 return r
  74         } <|> do {
  75                 -- define or label
  76                 s <- foldl1 (<|>) (fmap (try . string . fst) d);
  77                 return $ (get_elem s d)
  78         } <|> try (do {
  79                 string "0";
  80                 r <- hexadecimal;
  81                 return $ fromInteger r
  82         } ) <|> do {
  83                 r <- decimal;
  84                 return $ fromInteger r
  85         } <?> "factor"
  86
  87 testExpr :: String -> IO ()
  88 testExpr i = case (parse (expr dict) "" i) of
  89         Left err -> do {putStr "failz ;(\n"; print err}
  90         Right x -> do {printf "erg: 0x%08x\n" x}
  91         where
  92         dict = [("lolz", 0x1337), ("rofl", 0xaaaa)]