Commit 92381874 authored by Martin Ceresa's avatar Martin Ceresa
Browse files

push inicial

parents
# Bienvenidos al Compilador!
Esta es una versión vieja del compilador en Haskell. Se tiene todo lo que se necesita
más un montón de cosas que no se necesitan.
Está pensado para ser desarrollado en 2 partes, [Haskell1] vendría a ser una suerte de
primer entrega, y [Haskell2] vendría a ser lo que falta para la segunda parte.
*.swp
*.hi
*.o
*.swo
import TigerAbs
import TigerEscap
import qualified Data.Text as T
ejemplo1 :: Exp -- La variable a escapa.
ejemplo1 = LetExp
[ VarDec (T.pack "a") Nothing Nothing (IntExp 1 (1,1)) (1,2)
, FunctionDec
[ (T.pack "f1",[( T.pack "a1", Nothing, NameTy $ T.pack "int")], Just $ T.pack "int",VarExp (SimpleVar $ T.pack "a") (5,5),(5,2))]
]
(IntExp 42 (8,1))
(1,0)
ejemplo2 :: Exp -- La variable b no está definida.
ejemplo2 = LetExp
[ VarDec (T.pack "a") Nothing Nothing (IntExp 1 (1,2)) (1,2)
-- , VarDec "b" Nothing Nothing (IntExp 2 1) 2
-- , VarDec "c" Nothing Nothing (IntExp 3 1) 3
, FunctionDec
[ (T.pack "f1",[(T.pack "a1", Nothing, NameTy $ T.pack "int")], Just $ T.pack "int",VarExp (SimpleVar $ T.pack "b") (5,5),(5,6))]
]
(IntExp 42 (8,1))
(1,0)
{-# LANGUAGE GADTs #-}
module TigerAbs where
import TigerSymbol
-- | Pos representa la posición, simple de una linea y columna, o bien un rango
-- de posiciones
data Pos = Simple {line::Int, col :: Int} | Range Pos Pos
deriving Show
posToLabel :: Pos -> String
posToLabel (Simple l r) = (show l) ++ '.':(show r)
posToLabel (Range l r) = (posToLabel l) ++ '.':(posToLabel r)
printPos :: Pos -> String
printPos (Simple l c) = "[L:" ++ show l ++".C:"++ show c++"]"
printPos (Range b e) = "Entre --" ++ printPos b ++ " | " ++ printPos e
-- | Representamos las variables
data Var where
-- | Nombre de variable. Por ejemplo '(a+1)', 'a' se representa con una
-- SimpleVar "a".
SimpleVar :: Symbol -> Var
-- | Representa el acceso a un campo particular de un record. Pj: a.pepe.
-- daría a la construcción de FieldVar (SimpleVar "a") "pepe"
FieldVar :: Var -> Symbol -> Var
-- | Representa el acceso a un elemento de un array. Pj: a[(3+4)]. Daría a
-- la construcción de: SubscriptVar (SimpleVar "a") (OpExp (IntExp 3) PlusOp
-- (IntExp 4))
SubscriptVar :: Var -> Exp -> Var
deriving Show
-- | Tipo que representa las expresiones de tiger! Todos los constructores
-- llevan la posición en la que se encuentra el texto en el código fuente que
-- dio lugar a la construcción del AST.
data Exp where
-- | Representa una variable, el resultado es otorgar el valor de la
-- variable.
VarExp :: Var -> Pos -> Exp
-- | Unit, no es posible escribir unit en el lenguaje fuente.
UnitExp :: Pos -> Exp
-- | Break
BreakExp :: Pos -> Exp
-- | Nil
NilExp :: Pos -> Exp
-- | Enteros
IntExp :: Int -> Pos -> Exp
-- | Cadenas de texto
StringExp :: String -> Pos -> Exp
-- | Llamada de una función. Ej: f (45). Daría lugar al sig árbol: CallExp
-- "f" [IntExp 45] Pos
CallExp :: Symbol -> [Exp] -> Pos -> Exp
-- | Operaciones. Ej: 3+4. (OpExp (IntExp 3) PlusOp (IntExp 4))
OpExp :: Exp -> Oper -> Exp -> Pos -> Exp
-- | Records, representa un valor de un tipo record. Pj: lista{hd=1;tail=nil}
-- nos daría un AST: RecordExp [("hd",IntExp 1),("tail",NilExp)] "lista"
-- Pos. Recuerden, nos genera un valor de tipo record.
RecordExp :: [(Symbol, Exp)] -> Symbol -> Pos -> Exp
-- | SEcuencia de expresiones, el valor debería estar dictado por la ultima.
-- Ej: 4 ; print("Holis") ; 0. Genera: SeqExp [IntExp 4 Pos,
-- CallExp "print" [StringExp "Holis"] Pos, IntExp 0 Pos] Pos
SeqExp :: [Exp] -> Pos -> Exp
-- | Asignación. Ej: a := 3. AssignExp (SimpleVar "a") (IntExp 3 Pos) Pos
AssignExp :: Var -> Exp -> Pos -> Exp
-- | Condicional. Ej: if 3 then print("pepe"). Genera: IfExp (IntExp 3 Pos)
-- (CallExp "print" ["pepe"] Pos) NONE Pos
IfExp :: Exp -> Exp -> Maybe Exp -> Pos -> Exp
-- | Bucle while.
WhileExp :: Exp -> Exp -> Pos -> Exp
-- | Bucle for.
ForExp :: Symbol -> Maybe Bool -> Exp -> Exp -> Exp -> Pos -> Exp
-- | Expresiones tipo let. Es el único lugar donde pueden declarar nuevas
-- varibles, tipos y funciones. Ej: let var a := 3 in a end genera el árbol:
-- LetExp [VarDec "a" Nothing Nothing (IntExp 3 Pos) Pos] (SimpleVar "a")
-- Pos
LetExp :: [Dec] -> Exp -> Pos -> Exp
-- | Representa un valor de tipo Arreglo. Nos define un nuevo valor de tipo
-- arreglo. Pj: intArray [3+4] of (2*2). Nos genra el árbol: ArrayExp
-- "intArray" (OpExp (IntExp 3 Pos) PlusOp (IntExp 4 Pos)) (OpExp (IntExp 2
-- Pos) TimesOp (IntExp 2 Pos)) Pos
ArrayExp :: Symbol -> Exp -> Exp -> Pos -> Exp
deriving Show
-- | Declaraciones!
data Dec where
FunctionDec :: [(Symbol,[Field], Maybe Symbol, Exp, Pos)] -> Dec
VarDec :: Symbol -> Maybe Bool -> Maybe Symbol -> Exp -> Pos -> Dec
TypeDec :: [(Symbol, Ty, Pos)] -> Dec
deriving Show
data Ty = NameTy Symbol | RecordTy [Field] | ArrayTy Symbol
deriving Show
data Oper = PlusOp | MinusOp | TimesOp | DivideOp | EqOp | NeqOp | LtOp | LeOp | GtOp | GeOp
deriving Show
type Field = (Symbol, Maybe Bool, Ty)
module TigerEnv where
-- import qualified Data.Map.Strict as M
-- import qualified Data.List as L
class Environmental w where
lookupI ::(Ord a) => a -> w a d -> Maybe d -- Buscar
insertI ::(Ord a) => a -> d -> w a d -> w a d
intersecI :: (Ord a) => (d -> d -> d) -> w a d -> w a d -> w a d
updateI :: (Ord a) => a -> d -> w a d -> w a d
emptyI :: w a d
fromList :: (Ord a, Environmental m) => [(a,k)] -> m a k
fromList = foldl (\env (k,d) -> insertI k d env) emptyI
module TigerErrores where
import TigerSymbol
class Daemon w where
derror :: Symbol -> w a
handle :: w a -> (Symbol -> w a) -> w a
adder :: w a -> Symbol -> w a
adder w s = handle w (derror . append s)
internal :: Symbol -> w a
internal = derror . addStr "Internal: "
notfound :: Symbol -> w a
notfound = derror . addStr "Not found:"
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module TigerEscap where
import Data.Functor.Identity
import qualified Data.Map.Strict as M
import Data.Maybe
import Prelude hiding (error, lookup)
import qualified Prelude as P (error)
import TigerAbs
import TigerEnv
import TigerErrores
import TigerSymbol
import Control.Monad (when)
import Control.Monad.Except
import Control.Monad.State (get, put)
import qualified Control.Monad.State as ST
-- Debugging
import Debug.Trace
data Errores = NotFound Symbol
| Interno Symbol
instance Show Errores where
show (NotFound e) = "No se encuentra la variable "++ show e
show (Interno e) = "Error interno " ++ show e
eappend (NotFound e) e1 = NotFound (append e e1)
eappend (Interno e) e1 = Interno (append e e1)
type Depth = Int
type Dat = (Int , Maybe Bool)
type Env = M.Map Symbol Dat
data Estado = S { lvl :: Int, env :: Env}
deriving Show
data SEstado = Step { l :: Int, e :: [Env]}
deriving Show
class (Daemon m, Monad m) => Escapator m where
-- Depth Operators
depth :: m Depth
up :: m ()
down :: m ()
-- Env operators
setEnv :: M.Map Symbol Dat -> m ()
getEnv :: m (M.Map Symbol Dat)
--
-- Funciones cpor default, o de debugging
-- debugging
printEnv :: m () --
-- errores
putNum :: Pos -> Symbol -> m a
putNum ln er = derror $ append er $ pack $ printPos ln
raise :: Symbol -> m a
raise = derror
---
update :: Symbol -> Maybe Bool -> m ()
update s mb = do
m <- getEnv
case M.lookup s m of
Nothing -> notfound s
(Just (l,_)) -> setEnv (M.insert s (l,mb) m)
lookup :: Symbol -> m (Maybe (Int, Maybe Bool))
lookup s = do
m <- getEnv
return $ M.lookup s m
insert :: Symbol -> Maybe Bool -> m (M.Map Symbol Dat)
insert s mb = do
old <- getEnv
lvl <- depth
setEnv (M.insert s (lvl,mb) old)
return old
updateEnv :: M.Map Symbol Dat -> m ()
updateEnv m = do
actual <- getEnv
let newEnv = M.intersectionWith (\ (olvl, oesc) (nlvl,nesc) -> if olvl == nlvl then (olvl, nesc) else (olvl,oesc)) m actual
setEnv newEnv
type Stepper = ST.StateT SEstado (Either Errores)
instance Daemon Stepper where
derror = throwError . Interno
handle m f = catchError m ( f . pack . show)
instance Escapator Stepper where
depth = do
s <- ST.get
return (l s)
up = do
(Step lvl env) <- ST.get
ST.put (Step (lvl+1) env)
down = do
(Step lvl env) <- ST.get
ST.put (Step (lvl-1) env)
setEnv e = do
(Step lvl xs) <- get
put (Step lvl (e:xs))
getEnv = do
(Step _ (e:es)) <- ST.get
return e
printEnv = do
(Step l env) <- ST.get
return (trace ("Entorno(" ++ show l ++")" ++ show env ++ "*****\n") ())
type Completor = ST.StateT Estado (Either Errores)
instance Daemon Completor where
derror = throwError . Interno
handle m f = catchError m (f . pack . show)
adder e e1 = handle e (\s -> derror $ append e1 s )
instance Escapator Completor where
depth = do
s <- ST.get
return (lvl s)
up = do
(S lvl env) <- ST.get
ST.put (S (lvl+1) env)
down = do
(S lvl env) <- ST.get
ST.put (S (lvl-1) env)
setEnv e = do
(S lvl _) <- get
put (S lvl e)
getEnv = do
(S _ e) <- get
return e
printEnv = do
(S l env) <- get
return (trace ("Entorno(" ++ show l ++")" ++ show env ++ "*****\n") ())
type Simpler= ST.State Estado -- Sin manejo de Errores...
instance Daemon Simpler where
derror s = P.error $ unpack s
handle m _ = m -- no se maneja esto..
instance Escapator Simpler where -- No error
depth = do
s <- ST.get
return (lvl s)
up = do
(S lvl env) <- ST.get
ST.put (S (lvl+1) env)
down = do
(S lvl env) <- ST.get
ST.put (S (lvl-1) env)
setEnv e = do
(S lvl _) <- get
put (S lvl e)
getEnv = do
(S _ e) <- get
return e
printEnv = do
(S l env) <- get
return (trace ("Entorno(" ++ show l ++")" ++ show env ++ "*****\n") ())
travVar :: (Escapator m) => Var -> m Var
travVar (SimpleVar s) = do
s' <- lookup s
actLvl <- depth
case s' of
Nothing -> notfound s
Just (lvl, esc) -> when (actLvl > lvl) $ update s (Just True)
return (SimpleVar s)
travVar (FieldVar v p) = do
v' <- travVar v -- v._
return (FieldVar v' p)
travVar (SubscriptVar v e) = do
v' <- travVar v
e' <- travExp e
return (SubscriptVar v' e')
travExp :: (Escapator m) => Exp -> m Exp
travExp (VarExp v p) = do
v' <- handle (travVar v) (putNum p)
return (VarExp v' p)
travExp (CallExp s args p) = do
args' <- mapM travExp args
return (CallExp s args' p)
travExp (OpExp l op r p) = do
l' <- travExp l
r' <- travExp r
return (OpExp l' op r' p)
travExp (RecordExp es s p) = do
es' <- mapM (\(s,e) -> do
e' <- travExp e
return (s,e')) es
return (RecordExp es' s p)
travExp (SeqExp es p) = do
es' <- mapM travExp es
return (SeqExp es' p)
travExp (AssignExp v e p) = do
v' <- handle (travVar v) (putNum p)
e' <- travExp e
return (AssignExp v' e' p)
travExp (IfExp c t Nothing p) = do
c' <- travExp c
t' <- travExp t
return (IfExp c' t' Nothing p)
travExp (IfExp c t (Just e) p) = do
c' <- travExp c
t' <- travExp t
e' <- travExp e
return (IfExp c' t' (Just e') p)
travExp (WhileExp c b p) = do
c' <- travExp c
b' <- travExp b
return (WhileExp c' b' p)
travExp (ForExp s e lo hi body p) = do
lo' <- travExp lo
hi' <- travExp hi
old <- insert s e
body' <- travExp body
setEnv old
return (ForExp s e lo' hi' body' p)
travExp (LetExp ds e p) = do
old <- getEnv -- Security Measures <--
ds' <- mapM travDecs ds
e' <- travExp e
ds'' <- mapM (\case
(VarDec name _ typ exp p) -> do
chk <- lookup name
case chk of
Nothing -> internal $ pack $ "666+1 -- Linea:" ++ show p
Just (_,esc) ->
let newvardec = VarDec name esc typ exp p in
return newvardec
l -> return l) ds'
updateEnv old
return (LetExp ds'' e' p)
travExp (ArrayExp typ size init p) = do
s' <- travExp size
init' <- travExp init
return (ArrayExp typ s' init' p)
travExp v = return v
travF :: (Escapator m) => (Symbol,[Field], Maybe Symbol, Exp, Pos) -> m (Symbol,[Field], Maybe Symbol, Exp, Pos)
travF (name, params, res, body, p) = do
old <- getEnv
mapM_ (\(name, esc, typ) -> insert name esc) params
body' <- travExp body
params' <- mapM (\(s,_,ty) -> do
mb <- lookup s
case mb of
Nothing -> internal $ pack $ "666+2 -- Linea:" ++ show p
Just (_,esc) -> return (s,esc,ty)) params
updateEnv old
return (name, params', res, body', p)
travDecs :: (Escapator m) => Dec -> m Dec
travDecs (FunctionDec ls) = do
up -- New level!!
ls' <- mapM travF ls
down -- Return to old lvl
return (FunctionDec ls')
travDecs (VarDec name esc typ init p) = do
init' <- travExp init
insert name esc
return (VarDec name esc typ init' p)
travDecs l = return l
initialSt :: Estado
initialSt = S 1 M.empty
calcularEsc :: Exp -> Exp
calcularEsc e = ST.evalState (travExp e) initialSt
showEnv :: Exp -> (Exp,Estado)
showEnv e = ST.runState (travExp e) initialSt
calcularEEsc :: Exp -> Either Errores Exp
calcularEEsc e = ST.evalStateT (travExp e) initialSt
initialStepper :: SEstado
initialStepper = Step 1 [M.empty]
debbugEnv :: Exp -> Either Errores (Exp,SEstado)
debbugEnv e = ST.runStateT (travExp e) initialStepper
module TigerLexer where
import TigerAbs
import qualified Data.Text as T
import Text.Parsec
import qualified Text.Parsec.Token as Tok
-- import Text.Parsec.Char
import qualified Text.Parsec.Text as PT
-- import Data.Functor.Identity
lexer :: Tok.TokenParser ()
lexer = Tok.makeTokenParser Tok.LanguageDef
{Tok.commentStart = "/*"
,Tok.commentEnd = "*/"
,Tok.commentLine = []
,Tok.nestedComments = True
,Tok.identStart = letter
,Tok.identLetter = alphaNum <|> char '_'
,Tok.opStart = oneOf ":,;=&|<=>+-*/."
,Tok.opLetter = char '='
,Tok.reservedNames = ["var","let","end","in","function","type","array","of","if","then","else","while","do","for","to","break","nil","()"]
,Tok.reservedOpNames = ["=","&","|","<","<=",">",">=","<>","+","-","*","/","\""]
,Tok.caseSensitive = False
}
reservedOp = Tok.reservedOp lexer
reserved = Tok.reserved lexer
toInt :: Integer -> Int
toInt = fromInteger
-- number :: PT.Parser Integer
number = do
n <- Tok.natural lexer
return (toInt n)
parens = Tok.parens lexer
commaSep = Tok.commaSep lexer
commaSep1 = Tok.commaSep1 lexer
semiSep = Tok.semiSep lexer
semiSep1 = Tok.semiSep1 lexer
identifier = Tok.identifier lexer
dot = Tok.dot lexer
colon = Tok.colon lexer
brackets = Tok.brackets lexer
braces = Tok.braces lexer
symbol = Tok.symbol lexer
stringLiteral = Tok.stringLiteral lexer
whiteSpace = Tok.whiteSpace lexer
module Main (main) where
import qualified System.Environment as Env
import System.Exit
import System.Console.GetOpt
import Control.Monad
import Data.Maybe
import Data.Either
import TigerAbs
import TigerParser
import TigerEscap
import TigerPretty
import TigerSeman
import Text.Parsec (runParser)
data Options = Options {
optArbol :: Bool
,optDebEscap :: Bool
}
deriving Show
defaultOptions :: Options
defaultOptions = Options {optArbol = False, optDebEscap = False }
options :: [OptDescr (Options -> Options)]
options = [ Option ['a'] ["arbol"] (NoArg (\opts -> opts {optArbol = True})) "Muestra el AST luego de haber realizado el cálculo de escapes"
, Option ['e'] ["escapada"] (NoArg (\opts -> opts {optDebEscap = True})) "Stepper escapadas"]
compilerOptions :: [String] -> IO (Options, [String])
compilerOptions argv = case getOpt Permute options argv of
(o,n,[]) -> return (foldl (flip id) defaultOptions o, n)
(_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
where
header = "Se usa: tiger fileName [OPTIONS] "
showExp :: Exp -> IO ()
showExp e = do
putStrLn "Mostramos el AST (PP Gracias a Emilio Lopez Junior)"
putStrLn $ renderExp e
calculoEscapadas :: Exp -> Options -> IO (Maybe Exp)
calculoEscapadas rawAST opt =
if optDebEscap opt then
case (debbugEnv rawAST) of
(Left errEsc) -> do
putStrLn "Error en el calculo de variables escapadas:"
print errEsc
return Nothing
(Right (exp,envs)) -> do
putStrLn "Stepper MODE!!! Bienvenidos a la fiesta de las variables escapadas"
mapM_ ((\str -> putStrLn str >> putStrLn "-------") . show) (reverse (e envs))
putStrLn "yes!!!"
return (Just exp)
else
case (calcularEEsc rawAST) of
(Left errEsc) -> do
putStrLn "Error en el calculo de variables escapadas:"
print errEsc
return Nothing
(Right escap) -> do
when (optArbol opt) (showExp escap)
(putStrLn "yes!!!")
return $ Just escap
main = do
s:opts <- Env.getArgs
(opts', _) <- compilerOptions opts
sourceCode <- readFile s
either (\err -> error $ "Parser error..." ++ show err)
(\ast -> do
east <- calculoEscapadas ast opts'
when (isNothing east) (error $ "Calculo escapadas")
print "Genial!") (runParser expression () s sourceCode)
module TigerParser where
import Text.Parsec
import Text.Parsec.String (Parser)
import qualified Text.Parsec.Token as Tok
import qualified Text.Parsec.Expr as Ex
import Data.Text hiding (map)
import TigerAbs
import TigerLexer
import TigerSymbol
binary s f assoc ln = Ex.Infix (do
reservedOp s
return (\e1 e2 -> OpExp e1 f e2 ln)) assoc
-- tthen e2 ln = Ex.Infix (
-- do