bf55193 · Idris-dev · git.iko.soy

git.iko.soy/Idris-dev

Add scope checking for FOVM code

commitbf5519300f717a243369b8b1f42ae33cf07150b9 authorEdwin Brady <ecb10@st-andrews.ac.uk> dateMon 6 Aug 2012, 21:44 (14 years ago) parent7c75851

3 files changed+83−14

compare with master

unifiedsplit

iif/testvm.iif+1−1 src/IRTS/LParser.hs+13−10 src/IRTS/Lang.hs+69−3

iif/testvm.iif+1−1

@@ -8,7 +8,7 @@ fun plus(x, y) = case x of {

99fun natToInt(x) = case x of {

1010 O => 0

11− | S(k) => natToInt(k) + 1

11+ | S(k) => let y = natToInt(k) in y + 1

1212 }

1313

1414fun main() = printNum(natToInt(plus(S(S(O)), S(S(O)))))

src/IRTS/LParser.hs+13−10

@@ -42,19 +42,22 @@ lchar = lexeme.char

4242

4343fovm :: FilePath -> IO ()

4444fovm f = do defs <- parseFOVM f

45− print $ toAlist defs

45+ let tagged = addTags defs

46+ let ctxtIn = addAlist tagged emptyContext

47+ let checked = checkDefs ctxtIn tagged

48+ print checked

4649

47−parseFOVM :: FilePath -> IO LDefs

50+parseFOVM :: FilePath -> IO [(Name, LDecl)]

4851parseFOVM fname = do putStrLn $ "Reading " ++ fname

4952 fp <- readFile fname

5053 case runParser pProgram () fname fp of

5154 Left err-> fail (show err)

5255 Right x -> return x

5356

54−pProgram :: LParser LDefs

57+pProgram :: LParser [(Name, LDecl)]

5558pProgram = do fs <- many1 pLDecl

5659 eof

57− return $ addAlist fs emptyContext

60+ return fs

5861

5962pLDecl :: LParser (Name, LDecl)

6063pLDecl = do reserved "data"

@@ -81,7 +84,11 @@ optable = [[binary "*" (\x y -> LOp LTimes [x,y]) AssocLeft,

8184binary name f assoc = Infix (do reservedOp name; return f) assoc

8285

8386pLExp' :: LParser LExp

84−pLExp' = try (do x <- iName [];

87+pLExp' = try (do reserved "printNum"; e <- pLExp

88+ return (LOp LPrintNum [e]))

89+ <|> try (do reserved "print"; e <- pLExp

90+ return (LOp LPrintStr [e]))

91+ <|> try (do x <- iName [];

8592 lchar '('

8693 args <- sepBy pLExp (lchar ',')

8794 lchar ')'

@@ -90,12 +97,8 @@ pLExp' = try (do x <- iName [];

9097 <|> pLConst

9198 <|> do reserved "let"; x <- iName []; lchar '='; v <- pLExp

9299 reserved "in"; e <- pLExp

93− return (LLet (Glob x) v e)

100+ return (LLet x v e)

94101 <|> pCase

95− <|> do reserved "printNum"; e <- pLExp

96− return (LOp LPrintNum [e])

97− <|> do reserved "print"; e <- pLExp

98− return (LOp LPrintStr [e])

99102 <|> do x <- iName []

100103 return (LV (Glob x))

101104

src/IRTS/Lang.hs+69−3

@@ -7,8 +7,8 @@ data LVar = Loc Int | Glob Name

88data LExp = LV LVar

99 | LApp Name [LExp]

10− | LLet LVar LExp LExp

11− | LCon Int [LExp]

10+ | LLet Name LExp LExp -- name just for pretty printing

11+ | LCon Int Name [LExp]

1212 | LCase LExp [LAlt]

1313 | LConst Const

1414 | LOp PrimFn [LExp]

@@ -29,5 +29,71 @@ data LDecl = LFun Name [Name] LExp -- name, arg names, definition

2929

3030type LDefs = Ctxt LDecl

3131

32−-- TODO: Add constructor tags, then scope and arity checker.

32+-- TODO: scope and arity checker.

33+

34+addTags :: [(Name, LDecl)] -> [(Name, LDecl)]

35+addTags ds = tag 0 ds

36+ where tag i ((n, LConstructor n' t a) : as)

37+ = (n, LConstructor n' i a) : tag (i + 1) as

38+ tag i (x : as) = x : tag i as

39+ tag i [] = []

40+

41+checkDefs :: LDefs -> [(Name, LDecl)] -> TC [(Name, LDecl)]

42+checkDefs ctxt [] = return []

43+checkDefs ctxt (con@(n, LConstructor _ _ _) : xs) = do xs' <- checkDefs ctxt xs

44+ return (con : xs')

45+checkDefs ctxt ((n, LFun n' args exp) : xs)

46+ = do exp' <- scopecheck ctxt (zip args [0..]) exp

47+ xs' <- checkDefs ctxt xs

48+ return ((n, LFun n' args exp') : xs')

49+

50+scopecheck :: LDefs -> [(Name, Int)] -> LExp -> TC LExp

51+scopecheck ctxt env tm = sc env tm where

52+ sc env (LV (Glob n))

53+ = case lookup n (reverse env) of -- most recent first

54+ Just i -> return (LV (Loc i))

55+ Nothing -> case lookupCtxt Nothing n ctxt of

56+ [LConstructor _ i ar] ->

57+ if ar == 0 then return (LCon i n [])

58+ else fail $ "Codegen error: Constructor " ++ show n ++

59+ " has arity " ++ show ar

60+ [_] -> return (LV (Glob n))

61+ [] -> fail $ "Codegen error: No such variable " ++ show n

62+ sc env (LApp f args)

63+ = do args' <- mapM (sc env) args

64+ case lookupCtxt Nothing f ctxt of

65+ [LConstructor n tag ar] ->

66+ if (ar == length args)

67+ then return $ LCon tag n args'

68+ else fail $ "Codegen error: Constructor " ++ show f ++

69+ " has arity " ++ show ar

70+ [_] -> return $ LApp f args'

71+ [] -> fail $ "Codegen error: No such variable " ++ show f

72+ sc env (LCase e alts)

73+ = do e' <- sc env e

74+ alts' <- mapM (scalt env) alts

75+ return (LCase e' alts')

76+ sc env (LLet n v e)

77+ = do v' <- sc env v

78+ e' <- sc (env ++ [(n, length env)]) e

79+ return (LLet n v' e')

80+ sc env (LOp prim args)

81+ = do args' <- mapM (sc env) args

82+ return (LOp prim args')

83+ sc env x = return x

84+

85+ scalt env (LConCase i n args e)

86+ = do let env' = env ++ zip args [length env..]

87+ tag <- case lookupCtxt Nothing n ctxt of

88+ [LConstructor _ i ar] ->

89+ if (length args == ar) then return i

90+ else fail $ "Codegen error: Constructor " ++ show n ++

91+ " has arity " ++ show ar

92+ _ -> fail $ "Codegen error: No constructor " ++ show n

93+ e' <- sc env' e

94+ return (LConCase tag n args e')

95+ scalt env (LConstCase c e) = do e' <- sc env e

96+ return (LConstCase c e')

97+ scalt env (LDefaultCase e) = do e' <- sc env e

98+ return (LDefaultCase e')

3399