--- /dev/null
+-- BNF Converter: Error Monad
+-- Copyright (C) 2004 Author: Aarne Ranta
+
+-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.
+module ErrM where
+
+-- the Error monad: like Maybe type with error msgs
+
+data Err a = Ok a | Bad String
+ deriving (Read, Show, Eq)
+
+instance Monad Err where
+ return = Ok
+ fail = Bad
+ Ok a >>= f = f a
+ Bad s >>= f = Bad s
--- /dev/null
+-- -*- haskell -*-
+-- This Alex file was machine-generated by the BNF converter
+{
+module Lexsyntax where
+
+import ErrM
+
+}
+
+
+$l = [a-zA-Z\192 - \255] # [\215 \247] -- isolatin1 letter FIXME
+$c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter FIXME
+$s = [a-z\222-\255] # [\247] -- small isolatin1 letter FIXME
+$d = [0-9] -- digit
+$i = [$l $d _ '] -- identifier character
+$u = [\0-\255] -- universal: any character
+
+@rsyms = -- symbols and non-identifier-like reserved words
+ \= | \; | \{ | \} | \( | \) | \+ \+ | \- \- | \- | \< | \< \= | \> | \> \= | \= \= | \! \= | \+ | \* | \/
+
+:-
+"//" [.]* ; -- Toss single line comments
+"/*" ([$u # \*] | \* [$u # \/])* ("*")+ "/" ;
+
+$white+ ;
+@rsyms { tok (\p s -> PT p (TS $ share s)) }
+
+$l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }
+
+
+$d+ { tok (\p s -> PT p (TI $ share s)) }
+
+
+{
+
+tok f p s = f p s
+
+share :: String -> String
+share = id
+
+data Tok =
+ TS !String -- reserved words and symbols
+ | TL !String -- string literals
+ | TI !String -- integer literals
+ | TV !String -- identifiers
+ | TD !String -- double precision float literals
+ | TC !String -- character literals
+
+ deriving (Eq,Show,Ord)
+
+data Token =
+ PT Posn Tok
+ | Err Posn
+ deriving (Eq,Show,Ord)
+
+tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l
+tokenPos (Err (Pn _ l _) :_) = "line " ++ show l
+tokenPos _ = "end of file"
+
+posLineCol (Pn _ l c) = (l,c)
+mkPosToken t@(PT p _) = (posLineCol p, prToken t)
+
+prToken t = case t of
+ PT _ (TS s) -> s
+ PT _ (TI s) -> s
+ PT _ (TV s) -> s
+ PT _ (TD s) -> s
+ PT _ (TC s) -> s
+
+ _ -> show t
+
+data BTree = N | B String Tok BTree BTree deriving (Show)
+
+eitherResIdent :: (String -> Tok) -> String -> Tok
+eitherResIdent tv s = treeFind resWords
+ where
+ treeFind N = tv s
+ treeFind (B a t left right) | s < a = treeFind left
+ | s > a = treeFind right
+ | s == a = t
+
+resWords = b "print" (b "false" (b "else" (b "bool" N N) N) (b "int" (b "if" N N) N)) (b "true" (b "readInt" (b "readBool" N N) N) (b "while" N N))
+ where b s = B s (TS s)
+
+unescapeInitTail :: String -> String
+unescapeInitTail = unesc . tail where
+ unesc s = case s of
+ '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
+ '\\':'n':cs -> '\n' : unesc cs
+ '\\':'t':cs -> '\t' : unesc cs
+ '"':[] -> []
+ c:cs -> c : unesc cs
+ _ -> []
+
+-------------------------------------------------------------------
+-- Alex wrapper code.
+-- A modified "posn" wrapper.
+-------------------------------------------------------------------
+
+data Posn = Pn !Int !Int !Int
+ deriving (Eq, Show,Ord)
+
+alexStartPos :: Posn
+alexStartPos = Pn 0 1 1
+
+alexMove :: Posn -> Char -> Posn
+alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1)
+alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1
+alexMove (Pn a l c) _ = Pn (a+1) l (c+1)
+
+type AlexInput = (Posn, -- current position,
+ Char, -- previous char
+ String) -- current input string
+
+tokens :: String -> [Token]
+tokens str = go (alexStartPos, '\n', str)
+ where
+ go :: (Posn, Char, String) -> [Token]
+ go inp@(pos, _, str) =
+ case alexScan inp 0 of
+ AlexEOF -> []
+ AlexError (pos, _, _) -> fail $ show pos ++ ": lexical error"
+ AlexSkip inp' len -> go inp'
+ AlexToken inp' len act -> act pos (take len str) : (go inp')
+
+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
+alexGetChar (p, c, []) = Nothing
+alexGetChar (p, _, (c:s)) =
+ let p' = alexMove p c
+ in p' `seq` Just (c, (p', c, s))
+
+alexInputPrevChar :: AlexInput -> Char
+alexInputPrevChar (p, c, s) = c
+}
--- /dev/null
+all:
+ happy -gca -idebug Parsyntax.y
+ alex -g Lexsyntax.x
+ latex Docsyntax.tex; dvips Docsyntax.dvi -o Docsyntax.ps
+ ghc -fglasgow-exts --make Testsyntax.hs -o Testsyntax
+clean:
+ -rm -f *.log *.aux *.hi *.o *.dvi
+ -rm -f Docsyntax.ps
+distclean: clean
+ -rm -f Docsyntax.* Lexsyntax.* Parsyntax.* Layoutsyntax.* Skelsyntax.* Printsyntax.* Testsyntax.* Abssyntax.* Testsyntax ErrM.* SharedString.* syntax.dtd XMLsyntax.* Makefile*
+
--- /dev/null
+-- This Happy file was machine-generated by the BNF converter
+{
+module Parsyntax where
+import Abssyntax
+import Lexsyntax
+import ErrM
+}
+
+%name pStms Stms
+%name pExp Exp
+
+-- no lexer declaration
+%monad { Err } { thenM } { returnM }
+%tokentype { Token }
+
+%token
+ '=' { PT _ (TS "=") }
+ ';' { PT _ (TS ";") }
+ '{' { PT _ (TS "{") }
+ '}' { PT _ (TS "}") }
+ '(' { PT _ (TS "(") }
+ ')' { PT _ (TS ")") }
+ '++' { PT _ (TS "++") }
+ '--' { PT _ (TS "--") }
+ '-' { PT _ (TS "-") }
+ '<' { PT _ (TS "<") }
+ '<=' { PT _ (TS "<=") }
+ '>' { PT _ (TS ">") }
+ '>=' { PT _ (TS ">=") }
+ '==' { PT _ (TS "==") }
+ '!=' { PT _ (TS "!=") }
+ '+' { PT _ (TS "+") }
+ '*' { PT _ (TS "*") }
+ '/' { PT _ (TS "/") }
+ 'bool' { PT _ (TS "bool") }
+ 'else' { PT _ (TS "else") }
+ 'false' { PT _ (TS "false") }
+ 'if' { PT _ (TS "if") }
+ 'int' { PT _ (TS "int") }
+ 'print' { PT _ (TS "print") }
+ 'readBool' { PT _ (TS "readBool") }
+ 'readInt' { PT _ (TS "readInt") }
+ 'true' { PT _ (TS "true") }
+ 'while' { PT _ (TS "while") }
+
+L_ident { PT _ (TV $$) }
+L_integ { PT _ (TI $$) }
+L_err { _ }
+
+
+%%
+
+Ident :: { Ident } : L_ident { Ident $1 }
+Integer :: { Integer } : L_integ { (read $1) :: Integer }
+
+Bool :: { Bool }
+Bool : 'true' { True }
+ | 'false' { False }
+
+
+Stm :: { Stm }
+Stm : Type Ident '=' Exp ';' { SDecl $1 $2 $4 }
+ | Type Ident ';' { decl_ $1 $2 }
+ | Exp ';' { SExp $1 }
+ | '{' ListStm '}' { SBlock (reverse $2) }
+ | 'if' '(' Exp ')' Stm { if_ $3 $5 }
+ | 'if' '(' Exp ')' Stm 'else' Stm { SIf $3 $5 $7 }
+ | 'while' '(' Exp ')' Stm { SWhile $3 $5 }
+ | 'print' Exp ';' { SPrint $2 }
+ | Stm ';' { $1 }
+
+
+Exp :: { Exp }
+Exp : Exp1 BOp Exp1 { BExp $1 $2 $3 }
+ | Exp1 { $1 }
+
+
+Exp1 :: { Exp }
+Exp1 : Exp1 Op1 Exp2 { op1_ $1 $2 $3 }
+ | Exp2 { $1 }
+
+
+Exp2 :: { Exp }
+Exp2 : Exp2 Op2 Exp3 { op2_ $1 $2 $3 }
+ | Exp3 { $1 }
+
+
+Exp3 :: { Exp }
+Exp3 : Ident '++' { postIncr_ $1 }
+ | Ident '--' { postDecr_ $1 }
+ | Ident { EVar $1 }
+ | Ident '=' Exp { EAss $1 $3 }
+ | Integer { EInt $1 }
+ | '-' Exp3 { ENeg $2 }
+ | Bool { EBool $1 }
+ | 'readInt' { EReadI }
+ | 'readBool' { EReadB }
+ | '(' Exp ')' { $2 }
+
+
+ListStm :: { [Stm] }
+ListStm : {- empty -} { [] }
+ | ListStm Stm { flip (:) $1 $2 }
+
+
+Stms :: { Stms }
+Stms : ListStm { Program (reverse $1) }
+
+
+BOp :: { BOp }
+BOp : '<' { Lt }
+ | '<=' { ELt }
+ | '>' { Gt }
+ | '>=' { EGt }
+ | '==' { Eq }
+ | '!=' { NEq }
+
+
+Op1 :: { Op }
+Op1 : '+' { Plus }
+ | '-' { Minus }
+
+
+Op2 :: { Op }
+Op2 : '*' { Times }
+ | '/' { Div }
+
+
+Op :: { Op }
+Op : Op1 { $1 }
+ | Op2 { $1 }
+
+
+Type :: { Type }
+Type : 'int' { TInt }
+ | 'bool' { TBool }
+
+
+
+{
+
+returnM :: a -> Err a
+returnM = return
+
+thenM :: Err a -> (a -> Err b) -> Err b
+thenM = (>>=)
+
+happyError :: [Token] -> Err a
+happyError ts =
+ Bad $ "syntax error at " ++ tokenPos ts ++ if null ts then [] else (" before " ++ unwords (map prToken (take 4 ts)))
+
+myLexer = tokens
+decl_ t_ v_ = SDecl t_ v_ EDefault
+if_ e_ s_ = SIf e_ s_ SNoop
+op1_ e1_ o_ e2_ = OpExp e1_ o_ e2_
+op2_ e1_ o_ e2_ = OpExp e1_ o_ e2_
+postIncr_ i_ = EPost i_ Plus
+postDecr_ i_ = EPost i_ Minus
+}
+
--- /dev/null
+module Printsyntax where
+
+-- pretty-printer generated by the BNF converter
+
+import Abssyntax
+import Char
+
+-- the top-level printing method
+printTree :: Print a => a -> String
+printTree = render . prt 0
+
+type Doc = [ShowS] -> [ShowS]
+
+doc :: ShowS -> Doc
+doc = (:)
+
+render :: Doc -> String
+render d = rend 0 (map ($ "") $ d []) "" where
+ rend i ss = case ss of
+ "[" :ts -> showChar '[' . rend i ts
+ "(" :ts -> showChar '(' . rend i ts
+ "{" :ts -> showChar '{' . new (i+1) . rend (i+1) ts
+ "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
+ "}" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
+ ";" :ts -> showChar ';' . new i . rend i ts
+ t : "," :ts -> showString t . space "," . rend i ts
+ t : ")" :ts -> showString t . showChar ')' . rend i ts
+ t : "]" :ts -> showString t . showChar ']' . rend i ts
+ t :ts -> space t . rend i ts
+ _ -> id
+ new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace
+ space t = showString t . (\s -> if null s then "" else (' ':s))
+
+parenth :: Doc -> Doc
+parenth ss = doc (showChar '(') . ss . doc (showChar ')')
+
+concatS :: [ShowS] -> ShowS
+concatS = foldr (.) id
+
+concatD :: [Doc] -> Doc
+concatD = foldr (.) id
+
+replicateS :: Int -> ShowS -> ShowS
+replicateS n f = concatS (replicate n f)
+
+-- the printer class does the job
+class Print a where
+ prt :: Int -> a -> Doc
+ prtList :: [a] -> Doc
+ prtList = concatD . map (prt 0)
+
+instance Print a => Print [a] where
+ prt _ = prtList
+
+instance Print Char where
+ prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
+ prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
+
+mkEsc :: Char -> Char -> ShowS
+mkEsc q s = case s of
+ _ | s == q -> showChar '\\' . showChar s
+ '\\'-> showString "\\\\"
+ '\n' -> showString "\\n"
+ '\t' -> showString "\\t"
+ _ -> showChar s
+
+prPrec :: Int -> Int -> Doc -> Doc
+prPrec i j = if j<i then parenth else id
+
+
+instance Print Integer where
+ prt _ x = doc (shows x)
+
+
+instance Print Double where
+ prt _ x = doc (shows x)
+
+
+instance Print Ident where
+ prt _ (Ident i) = doc (showString i)
+
+
+
+instance Print Bool where
+ prt i e = case e of
+ True -> prPrec i 0 (concatD [doc (showString "true")])
+ False -> prPrec i 0 (concatD [doc (showString "false")])
+
+
+instance Print Stm where
+ prt i e = case e of
+ SDecl type' id exp -> prPrec i 0 (concatD [prt 0 type' , prt 0 id , doc (showString "=") , prt 0 exp , doc (showString ";")])
+ SExp exp -> prPrec i 0 (concatD [prt 0 exp , doc (showString ";")])
+ SBlock stms -> prPrec i 0 (concatD [doc (showString "{") , prt 0 stms , doc (showString "}")])
+ SIf exp stm0 stm -> prPrec i 0 (concatD [doc (showString "if") , doc (showString "(") , prt 0 exp , doc (showString ")") , prt 0 stm0 , doc (showString "else") , prt 0 stm])
+ SWhile exp stm -> prPrec i 0 (concatD [doc (showString "while") , doc (showString "(") , prt 0 exp , doc (showString ")") , prt 0 stm])
+ SPrint exp -> prPrec i 0 (concatD [doc (showString "print") , prt 0 exp , doc (showString ";")])
+ SNoop -> prPrec i 0 (concatD [])
+
+ prtList es = case es of
+ [] -> (concatD [])
+ x:xs -> (concatD [prt 0 x , prt 0 xs])
+
+instance Print Exp where
+ prt i e = case e of
+ BExp exp0 bop exp -> prPrec i 0 (concatD [prt 1 exp0 , prt 0 bop , prt 1 exp])
+ EVar id -> prPrec i 3 (concatD [prt 0 id])
+ EAss id exp -> prPrec i 3 (concatD [prt 0 id , doc (showString "=") , prt 0 exp])
+ EInt n -> prPrec i 3 (concatD [prt 0 n])
+ ENeg exp -> prPrec i 3 (concatD [doc (showString "-") , prt 3 exp])
+ EBool bool -> prPrec i 3 (concatD [prt 0 bool])
+ EReadI -> prPrec i 3 (concatD [doc (showString "readInt")])
+ EReadB -> prPrec i 3 (concatD [doc (showString "readBool")])
+ ExpT type' exp -> prPrec i 0 (concatD [prt 0 type' , prt 0 exp])
+ EDefault -> prPrec i 0 (concatD [])
+ OpExp exp0 op exp -> prPrec i 0 (concatD [prt 0 exp0 , prt 0 op , prt 0 exp])
+ EPost id op -> prPrec i 0 (concatD [prt 0 id , prt 1 op])
+
+
+instance Print Stms where
+ prt i e = case e of
+ Program stms -> prPrec i 0 (concatD [prt 0 stms])
+
+
+instance Print BOp where
+ prt i e = case e of
+ Lt -> prPrec i 0 (concatD [doc (showString "<")])
+ ELt -> prPrec i 0 (concatD [doc (showString "<=")])
+ Gt -> prPrec i 0 (concatD [doc (showString ">")])
+ EGt -> prPrec i 0 (concatD [doc (showString ">=")])
+ Eq -> prPrec i 0 (concatD [doc (showString "==")])
+ NEq -> prPrec i 0 (concatD [doc (showString "!=")])
+
+
+instance Print Op where
+ prt i e = case e of
+ Plus -> prPrec i 1 (concatD [doc (showString "+")])
+ Minus -> prPrec i 1 (concatD [doc (showString "-")])
+ Times -> prPrec i 2 (concatD [doc (showString "*")])
+ Div -> prPrec i 2 (concatD [doc (showString "/")])
+
+
+instance Print Type where
+ prt i e = case e of
+ TInt -> prPrec i 0 (concatD [doc (showString "int")])
+ TBool -> prPrec i 0 (concatD [doc (showString "bool")])
+ NoType -> prPrec i 0 (concatD [])
+
+
+
--- /dev/null
+module Skelsyntax where
+
+-- Haskell module generated by the BNF converter
+
+import Abssyntax
+import ErrM
+type Result = Err String
+
+failure :: Show a => a -> Result
+failure x = Bad $ "Undefined case: " ++ show x
+
+transIdent :: Ident -> Result
+transIdent x = case x of
+ Ident str -> failure x
+
+
+transBool :: Bool -> Result
+transBool x = case x of
+ True -> failure x
+ False -> failure x
+
+
+transStm :: Stm -> Result
+transStm x = case x of
+ SDecl type' id exp -> failure x
+ SExp exp -> failure x
+ SBlock stms -> failure x
+ SIf exp stm0 stm -> failure x
+ SWhile exp stm -> failure x
+ SPrint exp -> failure x
+ SNoop -> failure x
+
+
+transExp :: Exp -> Result
+transExp x = case x of
+ BExp exp0 bop exp -> failure x
+ EVar id -> failure x
+ EAss id exp -> failure x
+ EInt n -> failure x
+ ENeg exp -> failure x
+ EBool bool -> failure x
+ EReadI -> failure x
+ EReadB -> failure x
+ ExpT type' exp -> failure x
+ EDefault -> failure x
+ OpExp exp0 op exp -> failure x
+ EPost id op -> failure x
+
+
+transStms :: Stms -> Result
+transStms x = case x of
+ Program stms -> failure x
+
+
+transBOp :: BOp -> Result
+transBOp x = case x of
+ Lt -> failure x
+ ELt -> failure x
+ Gt -> failure x
+ EGt -> failure x
+ Eq -> failure x
+ NEq -> failure x
+
+
+transOp :: Op -> Result
+transOp x = case x of
+ Plus -> failure x
+ Minus -> failure x
+ Times -> failure x
+ Div -> failure x
+
+
+transType :: Type -> Result
+transType x = case x of
+ TInt -> failure x
+ TBool -> failure x
+ NoType -> failure x
+
+
+
--- /dev/null
+-- automatically generated by BNF Converter
+module Main where
+
+
+import IO ( stdin, hGetContents )
+import System ( getArgs, getProgName )
+
+import Lexsyntax
+import Parsyntax
+import Skelsyntax
+import Printsyntax
+import Abssyntax
+
+import Typecheck
+import Control.Monad.State
+import Data.Map as Map hiding (showTree)
+
+
+
+
+import ErrM
+
+type ParseFun a = [Token] -> Err a
+
+myLLexer = myLexer
+
+type Verbosity = Int
+
+putStrV :: Verbosity -> String -> IO ()
+putStrV v s = if v > 1 then putStrLn s else return ()
+
+runFile :: Verbosity -> ParseFun Stms -> FilePath -> IO ()
+runFile v p f = putStrLn f >> readFile f >>= run v p
+
+run :: Verbosity -> ParseFun Stms -> String -> IO ()
+run v p s = let ts = myLLexer s in case p ts of
+ Bad s -> do
+ putStrLn "\nParse Failed...\n"
+ putStrV v "Tokens:"
+ putStrV v $ show ts
+ putStrLn s
+ Ok (Program s) -> do
+ putStrLn "\nParse Successful!"
+ showTree v (Program s)
+ runStateT (mapM typeCheckStm s) empty
+ return ()
+
+showTree :: (Show a, Print a) => Int -> a -> IO ()
+showTree v tree
+ = do
+ putStrV v $ "\n[Abstract Syntax]\n\n" ++ show tree
+ putStrV v $ "\n[Linearized tree]\n\n" ++ printTree tree
+
+main :: IO ()
+main = do args <- getArgs
+ case args of
+ [] -> hGetContents stdin >>= run 2 pStms
+ "-s":fs -> mapM_ (runFile 0 pStms) fs
+ fs -> mapM_ (runFile 2 pStms) fs
+
+
+
+
+
m <- get
put (insert i t m)
return NoType
- else fail "Så får du inte göra!!!"
+ else fail $ "Illegal to assign an expression of type "++show t2++" to variable "++show i++" of type "++show t2
typeCheckStm (SPrint e) = do
typeCheckExp e
return NoType
projects / proglang.git / commitdiff