diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Juan Francisco Cardona McCormick + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Juan Francisco Cardona McCormick nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ewe.cabal b/ewe.cabal new file mode 100644 --- /dev/null +++ b/ewe.cabal @@ -0,0 +1,31 @@ +-- Initial ewe.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +name: ewe +version: 0.1.0.12 +synopsis: An language to teach a programming +description: Another implementions of the EWE programming language originally developed by Kent D. Lee. EWE was an extension of the RAM programming language created by Sethi. +homepage: http://github.com/jfcmacro/ewe +license: BSD3 +license-file: LICENSE +author: Juan Francisco Cardona McCormick +maintainer: fcardona@eafit.edu.co +-- copyright: +category: Language +build-type: Simple +cabal-version: >=1.8 + + +executable ewe + main-is: Main.hs + -- other-modules: + Build-depends: base >=4.5 && < 5, parsec >=3.1.3 && < 4, transformers >=0.3, + mtl >= 2.1 + hs-source-dirs: src + other-modules: Language.EWE.Parser, Language.EWE.AbsSyn, + Language.EWE.VM, Language.EWE.Token + +source-repository head + type: git + location: git://github.com/jfcmacro/ewe.git + diff --git a/src/Language/EWE/AbsSyn.hs b/src/Language/EWE/AbsSyn.hs new file mode 100644 --- /dev/null +++ b/src/Language/EWE/AbsSyn.hs @@ -0,0 +1,56 @@ +module Language.EWE.AbsSyn where + +data AbsSyn = Empty + +data MRef = MRefI Int + | MRefId String + deriving (Eq, Show) + +data Cond = CLET + | CLT + | CGET + | CGT + | CE + | CNE + deriving (Eq,Show) + +type Equ = (String,Int) + +type Equates = [Equ] + +type Labels = [String] + +data Stmt = Stmt Labels Instr + deriving (Eq,Show) + +type Stmts = [Stmt] + +data Prog = Prg {stms :: Stmts + ,equates :: Equates} + deriving (Eq,Show) + +data Instr = IMMI MRef Int -- Move Memory Int + | IMMS MRef String -- Move Memory String + | IMRPC MRef Int -- Move Memory Relative PC + | SPC MRef -- Set PC + | IMMM MRef MRef -- Move Memory to Memory + | IAdd MRef MRef MRef -- Add two Memory References + | ISub MRef MRef MRef -- Sub two Memory References + | IMul MRef MRef MRef -- Mul two Memory References + | IDiv MRef MRef MRef -- Div two Memory References + | IMod MRef MRef MRef -- Mod two Memory References + | IMRI MRef MRef Int -- Move to Memory ref a Indexed Memory Pos + | IMMR MRef Int MRef -- Move to Index Memory Ref a Memory Ref + | IRI MRef -- Read an Int and stored into a Mem Ref + | IWI MRef -- Write an Int from a Mem Ref + | IRS MRef MRef -- Read a Str + | IWS MRef -- Write a Str + | IGI Int -- Goto to line + | IGS String -- Goto sym + | IFI MRef Cond MRef Int -- If Cond then Int + | IFS MRef Cond MRef String -- + | IH -- Halt + | IB -- Break + | INI + deriving (Eq,Show) + diff --git a/src/Language/EWE/Parser.hs b/src/Language/EWE/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Language/EWE/Parser.hs @@ -0,0 +1,316 @@ +module Language.EWE.Parser where + +import System.IO +import Control.Monad +import Text.Parsec +import Text.Parsec.Prim +import Text.ParserCombinators.Parsec hiding(try) +import Language.EWE.AbsSyn +import Language.EWE.EweLang(eweLangDef) +import qualified Language.EWE.Token as Tkn + +-- Parser generates from the language +pEweLexer = Tkn.makeTokenParser eweLangDef + +pIdentifier = Tkn.identifier pEweLexer +pReserved = Tkn.reserved pEweLexer +pReservedOp = Tkn.reservedOp pEweLexer +pParens = Tkn.parens pEweLexer +pBrackets = Tkn.brackets pEweLexer +pInteger = Tkn.integer pEweLexer +pComma = Tkn.comma pEweLexer +pWhiteSpace = Tkn.whiteSpace pEweLexer +pSymbol = Tkn.symbol pEweLexer +pLexeme = Tkn.lexeme pEweLexer + +-- Parser of EWE Language +pEWE:: String -> String -> Either ParseError Prog +pEWE inp name = parse pEweProg name inp + +pEweProg :: Parser Prog +pEweProg = pStmts + +pStmts :: Parser Prog +pStmts = do res <- sepEndBy pStmtLine pEOL + let (eq',st') = foldr f ([],[]) res + return $ Prg st' eq' + where f (e,s) (e',s') = (e++e',s:s') + +pLabel :: Parser String +pLabel = do id <- pId + char ':' + return $ id + "Parsing label" + +pStmtLine :: Parser (Equates, Stmt) +pStmtLine = do eqs <- pEquates + return $ (eqs, Stmt [] INI) + <|> + do l <- pLabels + char '\t' + ins <- pInstr + return $ ([], Stmt l ins) + <|> + do pWhiteSpace + return $ ([], Stmt [] INI) + + +pLabels :: Parser [String] +pLabels = pLabel `sepBy` pWhiteSpace + + +-- Instructions parsers +-- ::= ... +pInstr :: Parser Instr +pInstr = do instr <- choice [pPCInstr + ,pReadInt + ,pReadStr + ,pWriteInt + ,pWriteStr + ,pGoto + ,pIf + ,pOneKw + ,pPrefixMRef + ] + return instr + +-- "PC" ":=" +-- AbsSyn SPC (Set PC instruction) +pPCInstr :: Parser Instr +pPCInstr = do pReserved"PC" + pReservedOp ":=" + mr <- pMRef2 + return $ SPC mr + +-- "readInt" "(" ")" +-- AbsSyn IRI Instruction Read Int +-- "readStr" "(" ")" +-- AbsSyn IRS Instruction Read String + +-- pRead :: Parser Instr +-- pRead = do string "read" +-- (string "Int" >> pReadInt) <|> (string "Str" >> pReadStr) + +-- pReadInt :: Parser Instr +-- pReadInt = pInstr1MRef IRI + +-- pReadStr :: Parser Instr +-- pReadStr = do pSpaces +-- (mr1, mr2) <- pTokenB pReadMRefs +-- pSpaces +-- return $ IRS mr1 mr2 +pReadInt :: Parser Instr +pReadInt = do pReserved "readInt" + mr <- pParens pMRef2 + return $ IRI mr + +pReadStr :: Parser Instr +pReadStr = do pReserved "readStr" + (mr1,mr2) <- pParens p + return $ IRS mr1 mr2 + where p = do { mr1 <- pMRef2 ; pComma; mr2 <- pMRef2 ; return $ (mr1,mr2) } + +-- "writeStr" "(" ")" +-- AbsSyn IWS Instruction Write String +-- "writeInt" "(" ")" +-- AbsSyn IWI Instruction Write Int +-- pWrite :: Parser Instr +-- pWrite = do string "write" +-- (string "Int" >> pWriteInt) <|> (string "Str" >> pWriteStr) + +-- pWriteInt :: Parser Instr +-- pWriteInt = pInstr1MRef IWI + +-- pWriteStr :: Parser Instr +-- pWriteStr = pInstr1MRef IWS +pWriteInt :: Parser Instr +pWriteInt = do pReserved "writeInt" + mr <- pParens pMRef2 + return $ IWI mr + +pWriteStr :: Parser Instr +pWriteStr = do pReserved "writeStr" + mr <- pParens pMRef2 + return $ IWS mr + +-- "goto" Integer +-- "goto" Identifier +-- AbsSyn IGI Goto to line +-- AbsSyn IGS Goto to Symbol +pGoto:: Parser Instr +pGoto = do pReserved "goto" + iOrId <- pTknIntOrId + let instr = either IGI IGS iOrId + return instr + +-- "if" "then" "goto" Integer +-- "if" "then" "goto" Identifier +-- AbsSyn IFI If Cond then Int +-- AbsSyn IFS If Cont then Id +pIf :: Parser Instr +pIf = do pReserved "if" + mr1 <- pMRef2 + cnd <- pCond + mr2 <- pMRef2 + pReserved "then" + pReserved "goto" + iOrId <- pTknIntOrId + let instr = either (IFI mr1 cnd mr2) (IFS mr1 cnd mr2) iOrId + return instr + +-- "halt" +-- "break" +-- IH Instruction Halt +-- IB Instruciton Break +listOneKw :: [(String,Instr)] +listOneKw = [("halt", IH), ("break", IB)] + +pOneKw :: Parser Instr +pOneKw = choice + $ map (\(s,r) -> (pReserved s >> return r)) listOneKw + +pReadMRefs :: Parser (MRef,MRef) +pReadMRefs = do pParens (do mr1 <- pMRef2 + pComma + mr2 <- pMRef2 + return $ (mr1, mr2)) + +pInstr1MRef :: (MRef -> Instr) -> Parser Instr +pInstr1MRef f = + do mr <- pParens pMRef2 + return $ f mr + +pPrefixMRef :: Parser Instr +pPrefixMRef = + do pReserved "M" + op <- pBrackets pMRefOrIdx' + pReservedOp ":=" + either pIMMR pNextRHS op + <|> + (pLexeme pId >>= \id -> pReservedOp ":=" >> (pNextRHS (MRefId id))) + +pIMMR :: (MRef,Int) -> Parser Instr +pIMMR (mr1,i) = + do pReservedOp ":=" + mr2 <- pMRef2 + return $ IMMR mr1 i mr2 + +pNextRHS :: MRef -> Parser Instr +pNextRHS mr1 = + (pLexeme pInt >>= \i -> return $ IMMI mr1 i) + <|> + (pLexeme pId >>= \id -> pEndRHS mr1 (MRefId id)) + <|> + (pLexeme pStrLit >>= \str -> return $ IMMS mr1 str) + <|> + do pReserved "M" + op <- pBrackets (pTokenB pMRefOrIdx') + either (\(mr2,i) -> return $ IMRI mr1 mr2 i) (pEndRHS mr1) op + +pEndRHS :: MRef -> MRef -> Parser Instr +pEndRHS mr1 mr2 = option (IMMM mr1 mr2) (pPartialArith mr1 mr2) + +listAOps :: [(String, MRef -> MRef -> MRef -> Instr)] +listAOps = [("+",IAdd), ("-",ISub), ("*",IMul), ("/",IDiv), ("%",IMod)] + +pPartialArith :: MRef -> MRef -> Parser Instr +pPartialArith mr1 mr2 = + choice $ map g listAOps + where g (s,f) = pReservedOp s + >> pMRef2 + >>= \mr3 -> return $ f mr1 mr2 mr3 + +pMRefOrIdx' :: Parser (Either (MRef,Int) MRef) +pMRefOrIdx' = do mr <- pMRef2 + pReservedOp "+" + i <- pInteger -- i <- pInt + return $ Left (mr,(fromInteger i)) + <|> + (pInteger >>= \i -> return $ Right (MRefI (fromInteger i))) + +-- Helpers parser to identify an integer or identifier +pTknIntOrId :: Parser (Either Int String) +pTknIntOrId = (pLexeme pInt >>= return.Left) <|> (pLexeme pId >>= return.Right) + +pInt :: Parser Int +pInt = do l <- oneOf "123456789" + ls <- many digit + return $ (read (l:ls)) + <|> + do l <- oneOf "0" + notFollowedBy digit + return $ (read (l:[])) + +pId :: Parser String +pId = do l <- (letter <|> char '_') + ls <- many (alphaNum <|> char '_') + return $ l:ls + +-- String Literal Parser +pStrLit :: Parser String +pStrLit = between (pSymbol "\"") (pSymbol "\"") (many $ p) + <|> + between (pSymbol "'") (pSymbol "'") (many $ p) + where p = oneOf " :!#$%&*+./<=>?@\\^|-~()[]" <|> digit <|> letter +-- Parser candidates to delete, because are deprecated +pToken :: Parser a -> Parser a +pToken p = (p >>= \a -> many (char ' ') >> return a ) + +pTokenB :: Parser a -> Parser a +pTokenB p = do many (char ' ') + a <- p + many (char ' ') + return a + +pSpaces :: Parser () +pSpaces = many (char ' ') >> return () + +-- MemRef +pMRef2 :: Parser MRef +pMRef2 = do pReserved "M" + i<- pBrackets pInteger + return $ (MRefI (fromInteger i)) + <|> + (pIdentifier >>= (return.MRefId)) + + "pMRef2" + +-- Equates +pEqu :: Parser Equ +pEqu = do pReserved "equ" + id <- pIdentifier + pReserved "M" + i <- pBrackets pInteger + return $ (id,(fromInteger i)) + +pEquates :: Parser Equates +pEquates = do{ equates <- sepBy pEqu (pWhiteSpace <|> pEOL); eof; return equates } + + +-- Cond +listCond :: [(String,Cond)] +listCond = [(">",CLT) + ,(">=",CLET) + ,("<",CGT) + ,("<=",CGET) + ,("=",CE) + ,("<>",CNE)] + +pCond :: Parser Cond +pCond = choice $ map (\(s,r) -> (pReservedOp s >> return r)) listCond + +-- End of Line parser +pEOL :: Parser () +pEOL = (char '\n' >> return ()) <|> (string "\r\n" >> return ()) + +-- Basic Parsers for compiling assemble files +pOneLineComment :: Parser () +pOneLineComment = do try (string "#") + skipMany (satisfy (/= '\n')) + char '\n' + return () + +pEmptyLine :: Parser () +pEmptyLine = do pWhiteSpace + char '\n' + return () diff --git a/src/Language/EWE/Token.hs b/src/Language/EWE/Token.hs new file mode 100644 --- /dev/null +++ b/src/Language/EWE/Token.hs @@ -0,0 +1,725 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.Parsec.Token +-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007 +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : derek.a.elkins@gmail.com +-- Stability : provisional +-- Portability : non-portable (uses local universal quantification: PolymorphicComponents) +-- +-- A helper module to parse lexical elements (tokens). See 'makeTokenParser' +-- for a description of how to use it. +-- +----------------------------------------------------------------------------- + +-- This was done because the original doesn't use well isSpace. + +{-# LANGUAGE PolymorphicComponents, FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Language.EWE.Token + ( LanguageDef + , GenLanguageDef (..) + , TokenParser + , GenTokenParser (..) + , makeTokenParser + ) where + +import Data.Char ( isAlpha, toLower, toUpper, isSpace, digitToInt ) +import Data.List ( nub, sort ) +import Control.Monad.Identity +import Text.Parsec.Prim +import Text.Parsec.Char +import Text.Parsec.Combinator + +----------------------------------------------------------- +-- Language Definition +----------------------------------------------------------- + +type LanguageDef st = GenLanguageDef String st Identity + +-- | The @GenLanguageDef@ type is a record that contains all parameterizable +-- features of the 'Text.Parsec.Token' module. The module 'Text.Parsec.Language' +-- contains some default definitions. + +data GenLanguageDef s u m + = LanguageDef { + + -- | Describes the start of a block comment. Use the empty string if the + -- language doesn't support block comments. For example \"\/*\". + + commentStart :: String, + + -- | Describes the end of a block comment. Use the empty string if the + -- language doesn't support block comments. For example \"*\/\". + + commentEnd :: String, + + -- | Describes the start of a line comment. Use the empty string if the + -- language doesn't support line comments. For example \"\/\/\". + + commentLine :: String, + + -- | Set to 'True' if the language supports nested block comments. + + nestedComments :: Bool, + + -- | This parser should accept any start characters of identifiers. For + -- example @letter \<|> char \"_\"@. + + identStart :: ParsecT s u m Char, + + -- | This parser should accept any legal tail characters of identifiers. + -- For example @alphaNum \<|> char \"_\"@. + + identLetter :: ParsecT s u m Char, + + -- | This parser should accept any start characters of operators. For + -- example @oneOf \":!#$%&*+.\/\<=>?\@\\\\^|-~\"@ + + opStart :: ParsecT s u m Char, + + -- | This parser should accept any legal tail characters of operators. + -- Note that this parser should even be defined if the language doesn't + -- support user-defined operators, or otherwise the 'reservedOp' + -- parser won't work correctly. + + opLetter :: ParsecT s u m Char, + + -- | The list of reserved identifiers. + + reservedNames :: [String], + + -- | The list of reserved operators. + + reservedOpNames:: [String], + + -- | Set to 'True' if the language is case sensitive. + + caseSensitive :: Bool + + } + + ----------------------------------------------------------- + -- A first class module: TokenParser + ----------------------------------------------------------- + +type TokenParser st = GenTokenParser String st Identity + + -- | The type of the record that holds lexical parsers that work on + -- @s@ streams with state @u@ over a monad @m@. + +data GenTokenParser s u m + = TokenParser { + + -- | This lexeme parser parses a legal identifier. Returns the identifier + -- string. This parser will fail on identifiers that are reserved + -- words. Legal identifier (start) characters and reserved words are + -- defined in the 'LanguageDef' that is passed to + -- 'makeTokenParser'. An @identifier@ is treated as + -- a single token using 'try'. + + identifier :: ParsecT s u m String, + + -- | The lexeme parser @reserved name@ parses @symbol + -- name@, but it also checks that the @name@ is not a prefix of a + -- valid identifier. A @reserved@ word is treated as a single token + -- using 'try'. + + reserved :: String -> ParsecT s u m (), + + -- | This lexeme parser parses a legal operator. Returns the name of the + -- operator. This parser will fail on any operators that are reserved + -- operators. Legal operator (start) characters and reserved operators + -- are defined in the 'LanguageDef' that is passed to + -- 'makeTokenParser'. An @operator@ is treated as a + -- single token using 'try'. + + operator :: ParsecT s u m String, + + -- |The lexeme parser @reservedOp name@ parses @symbol + -- name@, but it also checks that the @name@ is not a prefix of a + -- valid operator. A @reservedOp@ is treated as a single token using + -- 'try'. + + reservedOp :: String -> ParsecT s u m (), + + + -- | This lexeme parser parses a single literal character. Returns the + -- literal character value. This parsers deals correctly with escape + -- sequences. The literal character is parsed according to the grammar + -- rules defined in the Haskell report (which matches most programming + -- languages quite closely). + + charLiteral :: ParsecT s u m Char, + + -- | This lexeme parser parses a literal string. Returns the literal + -- string value. This parsers deals correctly with escape sequences and + -- gaps. The literal string is parsed according to the grammar rules + -- defined in the Haskell report (which matches most programming + -- languages quite closely). + + stringLiteral :: ParsecT s u m String, + + -- | This lexeme parser parses a natural number (a positive whole + -- number). Returns the value of the number. The number can be + -- specified in 'decimal', 'hexadecimal' or + -- 'octal'. The number is parsed according to the grammar + -- rules in the Haskell report. + + natural :: ParsecT s u m Integer, + + -- | This lexeme parser parses an integer (a whole number). This parser + -- is like 'natural' except that it can be prefixed with + -- sign (i.e. \'-\' or \'+\'). Returns the value of the number. The + -- number can be specified in 'decimal', 'hexadecimal' + -- or 'octal'. The number is parsed according + -- to the grammar rules in the Haskell report. + + integer :: ParsecT s u m Integer, + + -- | This lexeme parser parses a floating point value. Returns the value + -- of the number. The number is parsed according to the grammar rules + -- defined in the Haskell report. + + float :: ParsecT s u m Double, + + -- | This lexeme parser parses either 'natural' or a 'float'. + -- Returns the value of the number. This parsers deals with + -- any overlap in the grammar rules for naturals and floats. The number + -- is parsed according to the grammar rules defined in the Haskell report. + + naturalOrFloat :: ParsecT s u m (Either Integer Double), + + -- | Parses a positive whole number in the decimal system. Returns the + -- value of the number. + + decimal :: ParsecT s u m Integer, + + -- | Parses a positive whole number in the hexadecimal system. The number + -- should be prefixed with \"0x\" or \"0X\". Returns the value of the + -- number. + + hexadecimal :: ParsecT s u m Integer, + + -- | Parses a positive whole number in the octal system. The number + -- should be prefixed with \"0o\" or \"0O\". Returns the value of the + -- number. + + octal :: ParsecT s u m Integer, + + -- | Lexeme parser @symbol s@ parses 'string' @s@ and skips + -- trailing white space. + + symbol :: String -> ParsecT s u m String, + + -- | @lexeme p@ first applies parser @p@ and than the 'whiteSpace' + -- parser, returning the value of @p@. Every lexical + -- token (lexeme) is defined using @lexeme@, this way every parse + -- starts at a point without white space. Parsers that use @lexeme@ are + -- called /lexeme/ parsers in this document. + -- + -- The only point where the 'whiteSpace' parser should be + -- called explicitly is the start of the main parser in order to skip + -- any leading white space. + -- + -- > mainParser = do{ whiteSpace + -- > ; ds <- many (lexeme digit) + -- > ; eof + -- > ; return (sum ds) + -- > } + + lexeme :: forall a. ParsecT s u m a -> ParsecT s u m a, + + -- | Parses any white space. White space consists of /zero/ or more + -- occurrences of a 'space', a line comment or a block (multi + -- line) comment. Block comments may be nested. How comments are + -- started and ended is defined in the 'LanguageDef' + -- that is passed to 'makeTokenParser'. + + whiteSpace :: ParsecT s u m (), + + -- | Lexeme parser @parens p@ parses @p@ enclosed in parenthesis, + -- returning the value of @p@. + + parens :: forall a. ParsecT s u m a -> ParsecT s u m a, + + -- | Lexeme parser @braces p@ parses @p@ enclosed in braces (\'{\' and + -- \'}\'), returning the value of @p@. + + braces :: forall a. ParsecT s u m a -> ParsecT s u m a, + + -- | Lexeme parser @angles p@ parses @p@ enclosed in angle brackets (\'\<\' + -- and \'>\'), returning the value of @p@. + + angles :: forall a. ParsecT s u m a -> ParsecT s u m a, + + -- | Lexeme parser @brackets p@ parses @p@ enclosed in brackets (\'[\' + -- and \']\'), returning the value of @p@. + + brackets :: forall a. ParsecT s u m a -> ParsecT s u m a, + + -- | DEPRECATED: Use 'brackets'. + + squares :: forall a. ParsecT s u m a -> ParsecT s u m a, + + -- | Lexeme parser |semi| parses the character \';\' and skips any + -- trailing white space. Returns the string \";\". + + semi :: ParsecT s u m String, + + -- | Lexeme parser @comma@ parses the character \',\' and skips any + -- trailing white space. Returns the string \",\". + + comma :: ParsecT s u m String, + + -- | Lexeme parser @colon@ parses the character \':\' and skips any + -- trailing white space. Returns the string \":\". + + colon :: ParsecT s u m String, + + -- | Lexeme parser @dot@ parses the character \'.\' and skips any + -- trailing white space. Returns the string \".\". + + dot :: ParsecT s u m String, + + -- | Lexeme parser @semiSep p@ parses /zero/ or more occurrences of @p@ + -- separated by 'semi'. Returns a list of values returned by + -- @p@. + + semiSep :: forall a . ParsecT s u m a -> ParsecT s u m [a], + + -- | Lexeme parser @semiSep1 p@ parses /one/ or more occurrences of @p@ + -- separated by 'semi'. Returns a list of values returned by @p@. + + semiSep1 :: forall a . ParsecT s u m a -> ParsecT s u m [a], + + -- | Lexeme parser @commaSep p@ parses /zero/ or more occurrences of + -- @p@ separated by 'comma'. Returns a list of values returned + -- by @p@. + + commaSep :: forall a . ParsecT s u m a -> ParsecT s u m [a], + + -- | Lexeme parser @commaSep1 p@ parses /one/ or more occurrences of + -- @p@ separated by 'comma'. Returns a list of values returned + -- by @p@. + + commaSep1 :: forall a . ParsecT s u m a -> ParsecT s u m [a] + } + + ----------------------------------------------------------- + -- Given a LanguageDef, create a token parser. + ----------------------------------------------------------- + + -- | The expression @makeTokenParser language@ creates a 'GenTokenParser' + -- record that contains lexical parsers that are + -- defined using the definitions in the @language@ record. + -- + -- The use of this function is quite stylized - one imports the + -- appropiate language definition and selects the lexical parsers that + -- are needed from the resulting 'GenTokenParser'. + -- + -- > module Main where + -- > + -- > import Text.Parsec + -- > import qualified Text.Parsec.Token as P + -- > import Text.Parsec.Language (haskellDef) + -- > + -- > -- The parser + -- > ... + -- > + -- > expr = parens expr + -- > <|> identifier + -- > <|> ... + -- > + -- > + -- > -- The lexer + -- > lexer = P.makeTokenParser haskellDef + -- > + -- > parens = P.parens lexer + -- > braces = P.braces lexer + -- > identifier = P.identifier lexer + -- > reserved = P.reserved lexer + -- > ... + +makeTokenParser :: (Stream s m Char) + => GenLanguageDef s u m -> GenTokenParser s u m +makeTokenParser languageDef + = TokenParser{ identifier = identifier + , reserved = reserved + , operator = operator + , reservedOp = reservedOp + + , charLiteral = charLiteral + , stringLiteral = stringLiteral + , natural = natural + , integer = integer + , float = float + , naturalOrFloat = naturalOrFloat + , decimal = decimal + , hexadecimal = hexadecimal + , octal = octal + + , symbol = symbol + , lexeme = lexeme + , whiteSpace = whiteSpace + + , parens = parens + , braces = braces + , angles = angles + , brackets = brackets + , squares = brackets + , semi = semi + , comma = comma + , colon = colon + , dot = dot + , semiSep = semiSep + , semiSep1 = semiSep1 + , commaSep = commaSep + , commaSep1 = commaSep1 + } + where + + ----------------------------------------------------------- + -- Bracketing + ----------------------------------------------------------- + parens p = between (symbol "(") (symbol ")") p + braces p = between (symbol "{") (symbol "}") p + angles p = between (symbol "<") (symbol ">") p + brackets p = between (symbol "[") (symbol "]") p + + semi = symbol ";" + comma = symbol "," + dot = symbol "." + colon = symbol ":" + + commaSep p = sepBy p comma + semiSep p = sepBy p semi + + commaSep1 p = sepBy1 p comma + semiSep1 p = sepBy1 p semi + + + ----------------------------------------------------------- + -- Chars & Strings + ----------------------------------------------------------- + charLiteral = lexeme (between (char '\'') + (char '\'' "end of character") + characterChar ) + "character" + + characterChar = charLetter <|> charEscape + "literal character" + + charEscape = do{ char '\\'; escapeCode } + charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026')) + + + + stringLiteral = lexeme ( + do{ str <- between (char '"') + (char '"' "end of string") + (many stringChar) + ; return (foldr (maybe id (:)) "" str) + } + "literal string") + + stringChar = do{ c <- stringLetter; return (Just c) } + <|> stringEscape + "string character" + + stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) + + stringEscape = do{ char '\\' + ; do{ escapeGap ; return Nothing } + <|> do{ escapeEmpty; return Nothing } + <|> do{ esc <- escapeCode; return (Just esc) } + } + + escapeEmpty = char '&' + escapeGap = do{ many1 space + ; char '\\' "end of string gap" + } + + + + -- escape codes + escapeCode = charEsc <|> charNum <|> charAscii <|> charControl + "escape code" + + charControl = do{ char '^' + ; code <- upper + ; return (toEnum (fromEnum code - fromEnum 'A')) + } + + charNum = do{ code <- decimal + <|> do{ char 'o'; number 8 octDigit } + <|> do{ char 'x'; number 16 hexDigit } + ; return (toEnum (fromInteger code)) + } + + charEsc = choice (map parseEsc escMap) + where + parseEsc (c,code) = do{ char c; return code } + + charAscii = choice (map parseAscii asciiMap) + where + parseAscii (asc,code) = try (do{ string asc; return code }) + + + -- escape code tables + escMap = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'") + asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) + + ascii2codes = ["BS","HT","LF","VT","FF","CR","SO","SI","EM", + "FS","GS","RS","US","SP"] + ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL", + "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB", + "CAN","SUB","ESC","DEL"] + + ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI', + '\EM','\FS','\GS','\RS','\US','\SP'] + ascii3 = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK', + '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK', + '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL'] + + + ----------------------------------------------------------- + -- Numbers + ----------------------------------------------------------- + naturalOrFloat = lexeme (natFloat) "number" + + float = lexeme floating "float" + integer = lexeme int "integer" + natural = lexeme nat "natural" + + + -- floats + floating = do{ n <- decimal + ; fractExponent n + } + + + natFloat = do{ char '0' + ; zeroNumFloat + } + <|> decimalFloat + + zeroNumFloat = do{ n <- hexadecimal <|> octal + ; return (Left n) + } + <|> decimalFloat + <|> fractFloat 0 + <|> return (Left 0) + + decimalFloat = do{ n <- decimal + ; option (Left n) + (fractFloat n) + } + + fractFloat n = do{ f <- fractExponent n + ; return (Right f) + } + + fractExponent n = do{ fract <- fraction + ; expo <- option 1.0 exponent' + ; return ((fromInteger n + fract)*expo) + } + <|> + do{ expo <- exponent' + ; return ((fromInteger n)*expo) + } + + fraction = do{ char '.' + ; digits <- many1 digit "fraction" + ; return (foldr op 0.0 digits) + } + "fraction" + where + op d f = (f + fromIntegral (digitToInt d))/10.0 + + exponent' = do{ oneOf "eE" + ; f <- sign + ; e <- decimal "exponent" + ; return (power (f e)) + } + "exponent" + where + power e | e < 0 = 1.0/power(-e) + | otherwise = fromInteger (10^e) + + + -- integers and naturals + int = do{ f <- lexeme sign + ; n <- nat + ; return (f n) + } + + sign = (char '-' >> return negate) + <|> (char '+' >> return id) + <|> return id + + nat = zeroNumber <|> decimal + + zeroNumber = do{ char '0' + ; hexadecimal <|> octal <|> decimal <|> return 0 + } + "" + + decimal = number 10 digit + hexadecimal = do{ oneOf "xX"; number 16 hexDigit } + octal = do{ oneOf "oO"; number 8 octDigit } + + number base baseDigit + = do{ digits <- many1 baseDigit + ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits + ; seq n (return n) + } + + ----------------------------------------------------------- + -- Operators & reserved ops + ----------------------------------------------------------- + reservedOp name = + lexeme $ try $ + do{ string name + ; notFollowedBy (opLetter languageDef) ("end of " ++ show name) + } + + operator = + lexeme $ try $ + do{ name <- oper + ; if (isReservedOp name) + then unexpected ("reserved operator " ++ show name) + else return name + } + + oper = + do{ c <- (opStart languageDef) + ; cs <- many (opLetter languageDef) + ; return (c:cs) + } + "operator" + + isReservedOp name = + isReserved (sort (reservedOpNames languageDef)) name + + + ----------------------------------------------------------- + -- Identifiers & Reserved words + ----------------------------------------------------------- + reserved name = + lexeme $ try $ + do{ caseString name + ; notFollowedBy (identLetter languageDef) ("end of " ++ show name) + } + + caseString name + | caseSensitive languageDef = string name + | otherwise = do{ walk name; return name } + where + walk [] = return () + walk (c:cs) = do{ caseChar c msg; walk cs } + + caseChar c | isAlpha c = char (toLower c) <|> char (toUpper c) + | otherwise = char c + + msg = show name + + + identifier = + lexeme $ try $ + do{ name <- ident + ; if (isReservedName name) + then unexpected ("reserved word " ++ show name) + else return name + } + + + ident + = do{ c <- identStart languageDef + ; cs <- many (identLetter languageDef) + ; return (c:cs) + } + "identifier" + + isReservedName name + = isReserved theReservedNames caseName + where + caseName | caseSensitive languageDef = name + | otherwise = map toLower name + + + isReserved names name + = scan names + where + scan [] = False + scan (r:rs) = case (compare r name) of + LT -> scan rs + EQ -> True + GT -> False + + theReservedNames + | caseSensitive languageDef = sort reserved + | otherwise = sort . map (map toLower) $ reserved + where + reserved = reservedNames languageDef + + + + ----------------------------------------------------------- + -- White space & symbols + ----------------------------------------------------------- + symbol name + = lexeme (string name) + + lexeme p + = do{ x <- p; whiteSpace; return x } + + + --whiteSpace + whiteSpace + | noLine && noMulti = skipMany (simpleSpace "") + | noLine = skipMany (simpleSpace <|> multiLineComment "") + | noMulti = skipMany (simpleSpace <|> oneLineComment "") + | otherwise = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment "") + where + noLine = null (commentLine languageDef) + noMulti = null (commentStart languageDef) + + + simpleSpace = + skipMany1 (satisfy (== ' ')) + --skipMany1 (satisfy isSpace) + + oneLineComment = + do{ try (string (commentLine languageDef)) + ; skipMany (satisfy (/= '\n')) + ; return () + } + + multiLineComment = + do { try (string (commentStart languageDef)) + ; inComment + } + + inComment + | nestedComments languageDef = inCommentMulti + | otherwise = inCommentSingle + + inCommentMulti + = do{ try (string (commentEnd languageDef)) ; return () } + <|> do{ multiLineComment ; inCommentMulti } + <|> do{ skipMany1 (noneOf startEnd) ; inCommentMulti } + <|> do{ oneOf startEnd ; inCommentMulti } + "end of comment" + where + startEnd = nub (commentEnd languageDef ++ commentStart languageDef) + + inCommentSingle + = do{ try (string (commentEnd languageDef)); return () } + <|> do{ skipMany1 (noneOf startEnd) ; inCommentSingle } + <|> do{ oneOf startEnd ; inCommentSingle } + "end of comment" + where + startEnd = nub (commentEnd languageDef ++ commentStart languageDef) diff --git a/src/Language/EWE/VM.hs b/src/Language/EWE/VM.hs new file mode 100644 --- /dev/null +++ b/src/Language/EWE/VM.hs @@ -0,0 +1,258 @@ + +module Language.EWE.VM where + +import Language.EWE.AbsSyn +import qualified Data.List as L +import qualified Data.Maybe as M +import Control.Monad.Trans.State.Lazy +import Control.Monad.Trans.Class(lift) +import Data.Char (ord,chr) +import System.IO(hFlush, stdout) +import System.Exit(exitWith,ExitCode(..)) + +type Memory = [(Int,Int)] + +emptyMemory :: Memory +emptyMemory = [] + +type PC = Int + +initPC :: PC +initPC = 0 + +data StateVM = StVM { mem :: Memory + , prg :: Prog + , pc :: PC + } + +type StateVMM = StateT StateVM IO + +mRef :: MRef -> Equates -> Int +mRef (MRefI i) _ = i +mRef (MRefId s) m = M.fromMaybe (error "No found") $ L.lookup s m + +outMem :: Int -> Memory -> (Memory,Int) +outMem r m = M.maybe ((r,0):m, 0) (\i -> (m,i)) (L.lookup r m) + +inMem :: Int -> Int -> Memory -> Memory +inMem = updateM emptyMemory + +updateM :: Memory -> Int -> Int -> Memory -> Memory +updateM m r v [] = (r,v):m +updateM m r v (d@(r',_):m') = updateM (d:m) r v m' + +incrPC :: StateVM -> Int +incrPC state = (pc state) + 1 + +ge :: StateVM -> Equates +ge = equates.prg + +evalInstr :: StateVMM () +evalInstr = do + st <- get + let pc' = pc st + prg' = prg st + (Stmt _ ci) = stms prg' !! pc' + st' = execInstr ci st + if (hasSideEffects ci) + then case (ci) of + (IRI _) -> do + i <- lift $ readInt "Enter an integer:" + let st'' = execIRI i ci st + put st'' + (IWI _) -> do + let (st'',i) = execIWI ci st + lift $ putStrLn (show i) + put st'' + (IRS _ _) -> do + s <- lift $ getLine + let st'' = execIRS s ci st + put st'' + (IWS _) -> do + let (st'',s) = execIWS ci st + lift $ putStrLn s + put st'' + (IH) -> lift $ exitWith ExitSuccess + (IB) -> lift $ exitWith ExitSuccess + else put st' + +execInstr :: Instr -> StateVM -> StateVM +execInstr (INI) state = + state { pc = incrPC state } +execInstr (IMMI mr i) state = + state { mem = inMem (mRef mr (ge state)) i (mem state) + , pc = incrPC state + } +execInstr (IMMS mr s) state = + state { mem = inMem (mRef mr (ge state)) (mRef (MRefId s) (ge state)) (mem state) + , pc = incrPC state + } +execInstr (IMRPC mr i) state = + state { mem = inMem (mRef mr (ge state)) ((pc state) + i) (mem state) + , pc = incrPC state + } +execInstr (SPC mr) state = + state { pc = (mRef mr (ge state)) + } +execInstr (IMMM mr1 mr2) state = + let m = mem state + ge' = ge state + (m', v) = outMem (mRef mr2 ge') m + in state { mem = inMem (mRef mr1 ge') v m' + , pc = incrPC state + } +execInstr (IAdd mrr mra mrb) state = comp (+) mrr mra mrb state +execInstr (ISub mrr mra mrb) state = comp (-) mrr mra mrb state +execInstr (IMul mrr mra mrb) state = comp (*) mrr mra mrb state +execInstr (IDiv mrr mra mrb) state = comp (div) mrr mra mrb state +execInstr (IMod mrr mra mrb) state = comp (mod) mrr mra mrb state +execInstr (IMRI mrr mr i) state = + let m = mem state + ge' = ge state + (m',v) = outMem (mRef mr ge') m + (m'', v')= outMem (v + i) m' + in state { mem = inMem (mRef mrr ge') v' m'' + , pc = incrPC state + } +execInstr (IMMR mri i mr) state = + let m = mem state + ge' = ge state + (m', v) = outMem (mRef mr ge') m + (m'', v') = outMem (mRef mri ge') m' + in state { mem = inMem (v' + i) v m'' + , pc = incrPC state + } +execInstr (IGI i) state = + let prg' = prg state + stms' = stms prg' + l' = length stms' + in state { pc = if (i >= 0 && i < l') + then i else error "Inst Pos not valid" + } +execInstr (IGS s) state = + let prg' = prg state + stms' = stms prg' + i = lookupLabel s stms' + in state { pc = i } +execInstr (IFI mra cond mrb i) state = + let m = mem state + pc' = pc state + ge' = ge state + prg' = prg state + stms' = stms prg' + l' = length stms' + (m',a) = outMem (mRef mra ge') m + (m'',b) = outMem (mRef mra ge') m' + op = fun cond + i' = if (i >= 0 && i < l') + then i else error "Inst Pos not valid in condition" + npc = if a `op` b then i' else pc' + 1 + in state { mem = m'' + , pc = npc + } +execInstr (IFS mra cond mrb s) state = + let m = mem state + pc' = pc state + ge' = ge state + prg' = prg state + stms' = stms prg' + l' = length stms' + (m',a) = outMem (mRef mra ge') m + (m'',b) = outMem (mRef mra ge') m' + op = fun cond + i = lookupLabel s stms' + npc = if a `op` b then i else pc' + 1 + in state { mem = m'' + , pc = npc + } + +execIRI :: Int -> Instr -> StateVM -> StateVM +execIRI i (IRI mr) state = + state { mem = inMem (mRef mr (ge state)) i (mem state) + , pc = incrPC state + } + +execIWI :: Instr -> StateVM -> (StateVM, Int) +execIWI (IWI mr ) state = + let m = mem state + ge' = ge state + (m', v) = outMem (mRef mr ge') m + in (state { mem = m', pc = incrPC state}, v) + +execIRS :: String -> Instr -> StateVM -> StateVM +execIRS s (IRS mr1 mr2) state = + let ge' = ge state + startP = mRef mr1 ge' + endP = mRef mr1 ge' + state' = moveStrInMem s startP endP state + in if (startP <= endP) + then state' { pc = incrPC state } + else error "IRS start > end" + +moveStrInMem :: String -> Int -> Int -> StateVM -> StateVM +moveStrInMem [] st en state + | st <= en = moveStrInMem [] (st+1) en (state { mem = inMem st 0 (mem state) }) + | otherwise = state +moveStrInMem (c:cs) st en state + | st <= en = moveStrInMem cs (st+1) en (state { mem = inMem st (ord c) (mem state) }) + | otherwise = state + +execIWS :: Instr -> StateVM -> (StateVM, String) +execIWS (IWS mr) state = + let ge' = ge state + start = mRef mr ge' + (state', s) = moveStrOutMem start [] state + in (state' {pc = incrPC state }, s) + +moveStrOutMem :: Int -> String -> StateVM -> (StateVM, String) +moveStrOutMem i s state = + let ge' = ge state + m = mem state + (m',v) = outMem i m + in if (v /= 0) + then moveStrOutMem (i+1) (s++[chr(v)]) (state { mem = m'}) + else (state, s) + +lookupLabel :: String -> Stmts -> Int +lookupLabel = lookupLabel' 0 + +lookupLabel' :: Int -> String -> Stmts -> Int +lookupLabel' n s [] = error "Label not found" +lookupLabel' n s ((Stmt [] _):stms) = lookupLabel' (n+1) s stms +lookupLabel' n s ((Stmt lbls _):stms) + | s `elem` lbls = n + | otherwise = lookupLabel' (n+1) s stms + +fun :: Cond -> (Int -> Int -> Bool) +fun CLET = (<=) +fun CLT = (<) +fun CGET = (>=) +fun CGT = (>) +fun CE = (==) +fun CNE = (/=) + +-- comp computes the functions that transform int values +comp :: (Int -> Int -> Int) -> MRef -> MRef -> MRef -> StateVM -> StateVM +comp f mrr mra mrb state = + let m = mem state + ge' = ge state + (m', a) = outMem (mRef mra ge') m + (m'', b) = outMem (mRef mrb ge') m' + in state { mem = inMem (mRef mrr ge') (a `f` b) m'' + , pc = incrPC state + } + +hasSideEffects :: Instr -> Bool +hasSideEffects (IRI _) = True +hasSideEffects (IWI _) = True +hasSideEffects (IRS _ _) = True +hasSideEffects (IWS _) = True +hasSideEffects (IH) = True +hasSideEffects (IB) = True +hasSideEffects _ = False + +readInt :: String -> IO Int +readInt msg = do + putStr (msg ++ "> ") + hFlush stdout + readLn diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,50 @@ +module Main where + +import Paths_ewe (version) +import System.Environment(getArgs) +import System.IO(openFile, hClose, IOMode(..), hGetContents, stdin, stdout + ,stderr, hPutStr, hPutStrLn) +import System.Exit(ExitCode(..),exitSuccess) +import Data.Version(Version(..), showVersion) +import System.Console.GetOpt +import Data.Maybe(fromMaybe) +import Language.EWE.Parser +import Language.EWE.AbsSyn +import Language.EWE.VM + +data Flag = EweVersion deriving Show + +options :: [OptDescr Flag] +options = + [ Option ['V','?'] ["version"] (NoArg EweVersion) "show version number" + ] + +compilerOpts :: [String] -> IO ([Flag], [String]) +compilerOpts argv = + case getOpt Permute options argv of + (o,n,[]) -> return (o,n) + (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) + where header = "Usage: ewe [OPTION...] files..." + +processFile :: FilePath -> IO () +processFile fp = do + hPutStr stdout $ "Processing file: " ++ fp + fh <- openFile fp ReadMode + s <- hGetContents fh + let pRes = pEWE s fp + case pRes of + Left err -> hPutStrLn stderr $ " Parsing error at " ++ (show err) + Right prog -> hPutStrLn stdout $ " is Ok" + hClose fh + +processFlags :: [Flag] -> IO () +processFlags = mapM_ processFlag + +processFlag :: Flag -> IO () +processFlag EweVersion = (hPutStrLn stdout $ "ewe version: " ++ (showVersion version)) >> exitSuccess + +main :: IO () +main = do + (flgs, fls) <- (getArgs >>= compilerOpts) + processFlags flgs + mapM_ processFile fls