From e9be0603d9dbd1caa6a0032cad0e39815cb8f38d Mon Sep 17 00:00:00 2001 From: Michael Andreen Date: Fri, 24 Feb 2006 11:55:49 +0000 Subject: [PATCH] hopefully compiles properly --- ErrM.hs | 16 +++++ Lexsyntax.x | 134 +++++++++++++++++++++++++++++++++++++++++ Makefile | 11 ++++ Parsyntax.y | 160 +++++++++++++++++++++++++++++++++++++++++++++++++ Printsyntax.hs | 150 ++++++++++++++++++++++++++++++++++++++++++++++ Skelsyntax.hs | 80 +++++++++++++++++++++++++ Testsyntax.hs | 64 ++++++++++++++++++++ Typecheck.hs | 2 +- 8 files changed, 616 insertions(+), 1 deletion(-) create mode 100644 ErrM.hs create mode 100644 Lexsyntax.x create mode 100644 Makefile create mode 100644 Parsyntax.y create mode 100644 Printsyntax.hs create mode 100644 Skelsyntax.hs create mode 100644 Testsyntax.hs diff --git a/ErrM.hs b/ErrM.hs new file mode 100644 index 0000000..b65a31b --- /dev/null +++ b/ErrM.hs @@ -0,0 +1,16 @@ +-- 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 diff --git a/Lexsyntax.x b/Lexsyntax.x new file mode 100644 index 0000000..00277a9 --- /dev/null +++ b/Lexsyntax.x @@ -0,0 +1,134 @@ +-- -*- 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 +} diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..883c65f --- /dev/null +++ b/Makefile @@ -0,0 +1,11 @@ +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* + diff --git a/Parsyntax.y b/Parsyntax.y new file mode 100644 index 0000000..6fef6ba --- /dev/null +++ b/Parsyntax.y @@ -0,0 +1,160 @@ +-- 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 +} + diff --git a/Printsyntax.hs b/Printsyntax.hs new file mode 100644 index 0000000..aeb3258 --- /dev/null +++ b/Printsyntax.hs @@ -0,0 +1,150 @@ +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 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 []) + + + diff --git a/Skelsyntax.hs b/Skelsyntax.hs new file mode 100644 index 0000000..c1af307 --- /dev/null +++ b/Skelsyntax.hs @@ -0,0 +1,80 @@ +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 + + + diff --git a/Testsyntax.hs b/Testsyntax.hs new file mode 100644 index 0000000..fb6986c --- /dev/null +++ b/Testsyntax.hs @@ -0,0 +1,64 @@ +-- 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 + + + + + diff --git a/Typecheck.hs b/Typecheck.hs index ec2270e..35ed382 100644 --- a/Typecheck.hs +++ b/Typecheck.hs @@ -63,7 +63,7 @@ typeCheckStm (SDecl t i e) = do 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 -- 2.39.2