From: Luke Lau <luke_lau@icloud.com>
Date: Thu, 11 Apr 2019 22:46:06 +0000 (+0100)
Subject: Add for loops
X-Git-Url: https://git.lukelau.me/?p=kaleidoscope-hs-old.git;a=commitdiff_plain

Add for loops
---

diff --git a/AST.hs b/AST.hs
index 99b6d42..e5ea72a 100644
--- a/AST.hs
+++ b/AST.hs
@@ -2,7 +2,7 @@ module AST where
 
 import Data.Char
 import Text.Read
-import Text.ParserCombinators.ReadP hiding ((+++), choice)
+import Text.ParserCombinators.ReadP hiding ((+++), (<++), choice)
 
 newtype Program = Program [AST]
   deriving Show
@@ -26,6 +26,7 @@ data Expr = Num Double
           | Var String
           | Call String [Expr]
           | If Expr Expr Expr
+          | For String Expr Expr (Maybe Expr) Expr
   deriving Show
 data BinOpType = Add | Sub | Mul | Cmp Ordering
   deriving Show
@@ -52,6 +53,7 @@ instance Read Expr where
                     , parseVar
                     , parseCall
                     , parseIf
+                    , parseFor
                     , parseBinOp "+" Add
                     , parseBinOp "-" Sub
                     , parseBinOp "*" Mul
@@ -92,3 +94,18 @@ instance Read Expr where
               skipSpaces
             elseE <- step readPrec
             return (If cond thenE elseE)
+          parseFor = do
+            lift $ do
+              string "for"
+              skipSpaces
+            identifier <- lift (munch1 isAlpha)
+            lift $ skipSpaces >> char '=' >> skipSpaces
+            start <- step readPrec
+            lift $ skipSpaces >> char ',' >> skipSpaces
+            cond <- step readPrec
+            step' <- (do
+              lift $ skipSpaces >> char ',' >> skipSpaces
+              Just <$> step readPrec) <++ pure Nothing
+            lift $ skipSpaces >> string "in" >> skipSpaces
+            body <- step readPrec
+            return (For identifier start cond step' body)
diff --git a/Main.hs b/Main.hs
index f096ea6..7fa4499 100644
--- a/Main.hs
+++ b/Main.hs
@@ -44,14 +44,14 @@ main = do
     Left err -> die err
     Right mdl' -> withContext $ \ctx ->
       withHostTargetMachine $ \tm -> do
-        -- hPutStrLn stderr "Before optimisation:"
-        -- Text.hPutStrLn stderr (ppllvm mdl')
+        hPutStrLn stderr "Before optimisation:"
+        Text.hPutStrLn stderr (ppllvm mdl')
 
         withModuleFromAST ctx mdl' $ \mdl -> do
           let spec = defaultCuratedPassSetSpec { optLevel = Just 3 }
           withPassManager spec $ flip runPassManager mdl
-          -- hPutStrLn stderr "After optimisation:"
-          -- Text.hPutStrLn stderr . ppllvm =<< moduleAST mdl
+          hPutStrLn stderr "After optimisation:"
+          Text.hPutStrLn stderr . ppllvm =<< moduleAST mdl
           jit tm mdl >>= print
 
 jit :: TargetMachine -> Module -> IO Double
@@ -153,3 +153,33 @@ buildExpr binds (AST.If cond thenE elseE) = mdo
 
   mergeB <- block `named` "ifcont"
   phi [(thenOp, thenB), (elseOp, elseB)]
+
+buildExpr binds (AST.For ident start cond mStep body) = mdo
+  startV <- buildExpr binds start
+
+  preheaderB <- block `named` "preheader"
+
+  br loopB
+
+  loopB <- block `named` "loop"
+
+  i <- phi [(startV, preheaderB), (nextVar, loopB)] `named` "i"
+
+  let newBinds = Map.insert ident i binds
+
+  buildExpr newBinds body `named` "body"
+
+  stepV <- case mStep of
+    Just step -> buildExpr newBinds step
+    Nothing -> pure $ ConstantOperand (Float (Double 1))
+
+  nextVar <- fadd i stepV `named` "nextvar"
+
+  condV <- buildExpr newBinds cond `named` "cond"
+
+  condBr condV loopB afterB
+
+  afterB <- block `named` "after"
+
+  return (ConstantOperand (Float (Double 0)))
+
diff --git a/test.ks b/test.ks
index c18328b..ed42175 100644
--- a/test.ks
+++ b/test.ks
@@ -1,3 +1,7 @@
-def foo(x y) if x > y then x + y else x - y;
-extern putchard(x);
+extern putchard(char);
+
+def printstar(n)
+	for i = 0, i < n, 1.0 in
 		putchard(42);
+
+printstar(100);