From: pimjager <pim@pimjager.nl>
Date: Fri, 20 May 2016 15:37:19 +0000 (+0200)
Subject: print specialised
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=a5c4e896f3f80da310ebd2a562672a47b62d323a;p=cc1516.git

print specialised
---

diff --git a/examples/codeGen.spl b/examples/codeGen.spl
index 1f76056..f41897d 100644
--- a/examples/codeGen.spl
+++ b/examples/codeGen.spl
@@ -26,6 +26,13 @@ isE(x) :: [a] -> Bool {
     }
 }
 
+test() {
+    var x =print(5);
+    print(True);
+    print('a');
+    print('h' : 'o' : 'i' : []);
+}
+
 main() {
  //   [Int] x2 = 0 : x1;
  //   [Int] x3 = [];
@@ -40,6 +47,7 @@ main() {
     var z = isEmpty(x1);
     //char c = read();
     x.hd.snd = 8;
-    isE(x1, 8);
+    isE(x1);
+    print(4);
     return;
 }
diff --git a/sem.icl b/sem.icl
index 29b89af..75b5585 100644
--- a/sem.icl
+++ b/sem.icl
@@ -185,7 +185,7 @@ lookup k = gamma >>= \g-> case 'Map'.member k g of
 //The inference class
 //When tying it all together we will treat the program is a big 
 //let x=e1 in let y=e2 in .... 
-class infer a :: a -> Typing (Substitution, Type)
+class infer a :: a -> Typing (Substitution, Type, a)
 
 ////---- Inference for Expressions ----
 
@@ -193,46 +193,54 @@ instance infer Expr where
  infer e = case e of
     VarExpr _ (VarDef k fs) = lookup k >>= \t ->
         foldM foldFieldSelectors t fs >>= \finalT ->
-        pure (zero, finalT)
+        pure (zero, finalT, e)
 
-    Op2Expr _ e1 op e2 =
-        infer e1 >>= \(s1, t1) -> 
-        infer e2 >>= \(s2, t2) ->
+    Op2Expr p e1 op e2 =
+        infer e1 >>= \(s1, t1, e1_) -> 
+        infer e2 >>= \(s2, t2, e2_) ->
         fresh >>= \tv ->
         let given = t1 ->> t2 ->> tv in 
         op2Type op >>= \expected ->
         lift (unify expected given) >>= \s3 ->
-        pure ((compose s3 $ compose s2 s1), subst s3 tv)
+        pure ((compose s3 $ compose s2 s1), subst s3 tv, Op2Expr p e1_ op e2_)
 
-    Op1Expr _ op e1 =
-        infer e1 >>= \(s1, t1) -> 
+    Op1Expr p op e1 =
+        infer e1 >>= \(s1, t1, e1_) -> 
         fresh >>= \tv ->
         let given = t1 ->> tv in 
         op1Type op >>= \expected ->
         lift (unify expected given) >>= \s2 ->
-        pure (compose s2 s1, subst s2 tv)
+        pure (compose s2 s1, subst s2 tv, Op1Expr p op e1)
 
-    EmptyListExpr _ = (\tv->(zero,tv)) <$> fresh
+    EmptyListExpr _ = (\tv->(zero,tv,e)) <$> fresh
 
-    TupleExpr _ (e1, e2) = 
-        infer e1 >>= \(s1, t1) -> 
-        infer e2 >>= \(s2, t2) ->
-        pure (compose s2 s1, TupleType (t1,t2))
+    TupleExpr p (e1, e2) = 
+        infer e1 >>= \(s1, t1, e1_) -> 
+        infer e2 >>= \(s2, t2, e2_) ->
+        pure (compose s2 s1, TupleType (t1,t2), TupleExpr p (e1_,e2_))
 
-    FunExpr _ f args fs = //todo: fieldselectors
+    FunExpr p f args fs = //todo: fix print
         lookup f >>= \expected ->
-        let accST = (\(s,ts) e->infer e >>= \(s_,et)->pure (compose s_ s,ts++[et])) in
-        foldM accST (zero,[]) args >>= \(s1, argTs)->
+        let accST = (\(s,ts,es) e->infer e >>= \(s_,et,e_)-> pure (compose s_ s,ts++[et],es++[e_])) in
+        foldM accST (zero,[],[]) args >>= \(s1, argTs, args_)->
         fresh >>= \tv->
         let given = foldr (->>) tv argTs in
         lift (unify expected given) >>= \s2->
         let fReturnType = subst s2 tv in
         foldM foldFieldSelectors fReturnType fs >>= \returnType ->
-        pure (compose s2 s1, returnType)
-
-    IntExpr _ _ = pure $ (zero, IntType)
-    BoolExpr _ _ = pure $ (zero, BoolType)
-    CharExpr _ _ = pure $ (zero, CharType)
+        (case f of
+            "print" = case head argTs of
+                IntType = pure "1printint"
+                CharType = pure "1printchar"
+                BoolType = pure "1printbool"
+                ListType (CharType) = pure "1printstr"
+                t = liftT $ Left $ SanityError p ("can not print " +++ toString t)
+            _ = pure f) >>= \newF->
+        pure (compose s2 s1, returnType, FunExpr p newF args_ fs)
+
+    IntExpr _ _ = pure $ (zero, IntType, e)
+    BoolExpr _ _ = pure $ (zero, BoolType, e)
+    CharExpr _ _ = pure $ (zero, CharType, e)
 
 foldFieldSelectors :: Type FieldSelector -> Typing Type 
 foldFieldSelectors (ListType t) (FieldHd) = pure t
@@ -265,47 +273,55 @@ applySubst s = changeGamma (subst s)
 instance infer Stmt where
  infer s = case s of
     IfStmt e th el = 
-        infer e >>= \(s1, et)->
+        infer e >>= \(s1, et, e_)->
         lift (unify et BoolType) >>= \s2 ->
         applySubst (compose s2 s1) >>|        
-        infer th >>= \(s3, tht)->
+        infer th >>= \(s3, tht, th_)->
         applySubst s3 >>|
-        infer el >>= \(s4, elt)->
+        infer el >>= \(s4, elt, el_)->
         applySubst s4 >>|
         lift (unify tht elt) >>= \s5-> 
-        pure (compose s5 $ compose s4 $ compose s3 $ compose s2 s1, subst s5 tht)
+        let sub = compose s5 $ compose s4 $ compose s3 $ compose s2 s1 in
+        pure (sub, subst s5 tht, IfStmt e_ th_ el_)
 
     WhileStmt e wh = 
-        infer e >>= \(s1, et)->
+        infer e >>= \(s1, et, e_)->
         lift (unify et BoolType) >>= \s2 ->
         applySubst (compose s2 s1) >>|
-        infer wh >>= \(s3, wht)->
-        pure (compose s3 $ compose s2 s1, subst s3 wht)
+        infer wh >>= \(s3, wht, wh_)->
+        pure (compose s3 $ compose s2 s1, subst s3 wht, WhileStmt e_ wh_)
 
-    AssStmt (VarDef k fs) e =
+    AssStmt vd=:(VarDef k fs) e =
         lookup k >>= \expected ->
-        infer e >>= \(s1, given)->
+        infer e >>= \(s1, given, e_)->
         foldM reverseFs given (reverse fs) >>= \varType->
         lift (unify expected varType) >>= \s2->
         let s = compose s2 s1 in
         applySubst s >>|
         changeGamma (extend k (Forall [] (subst s varType))) >>| 
-        pure (s, VoidType)
+        pure (s, VoidType, AssStmt vd e_)
 
-    FunStmt f es _ = pure (zero, VoidType) //Fix for print & check number of args
     FunStmt f args fs = 
         lookup f >>= \expected ->
-        let accST = (\(s,ts) e->infer e >>= \(s_,et)->pure (compose s_ s,ts++[et])) in
-        foldM accST (zero,[]) args >>= \(s1, argTs)->
+        let accST = (\(s,ts,es) e->infer e >>= \(s_,et,e_)-> pure (compose s_ s,ts++[et],es++[e_])) in
+        foldM accST (zero,[],[]) args >>= \(s1, argTs, args_)->
         fresh >>= \tv->
         let given = foldr (->>) tv argTs in
         lift (unify expected given) >>= \s2->
         let fReturnType = subst s2 tv in
-        foldM foldFieldSelectors fReturnType fs >>= \_ ->
-        pure (compose s2 s1, VoidType)
-
-    ReturnStmt Nothing = pure (zero, VoidType)
-    ReturnStmt (Just e) = infer e
+        foldM foldFieldSelectors fReturnType fs >>= \returnType ->
+        (case f of
+            "print" = case head argTs of
+                IntType = pure "1printint"
+                CharType = pure "1printchar"
+                BoolType = pure "1printbool"
+                ListType (CharType) = pure "1printstr"
+                t = liftT $ Left $ SanityError zero ("can not print " +++ toString t)
+            _ = pure f) >>= \newF->
+        pure (compose s2 s1, VoidType, FunStmt newF args_ fs)
+
+    ReturnStmt Nothing = pure (zero, VoidType, s)
+    ReturnStmt (Just e) = infer e >>= \(sub, t, _)-> pure (sub, t, s)
 
 reverseFs :: Type FieldSelector -> Typing Type 
 reverseFs t FieldHd = pure $ ListType t
@@ -316,18 +332,18 @@ reverseFs t FieldSnd = fresh >>= \tv -> pure $ TupleType (tv, t)
 //The type of a list of statements is either an encountered
 //return, or VoidType
 instance infer [a] | infer a where
-    infer []        = pure (zero, VoidType)
+    infer []        = pure (zero, VoidType, [])
     infer [stmt:ss] = 
-        infer stmt >>= \(s1, t1) ->
+        infer stmt >>= \(s1, t1, s_) ->
         applySubst s1 >>|
-        infer ss >>= \(s2, t2) ->
+        infer ss >>= \(s2, t2, ss_) ->
         applySubst s2 >>|
         case t1 of
-            VoidType = pure (compose s2 s1, t2)
+            VoidType = pure (compose s2 s1, t2, [s_:ss_])
             _ = case t2 of
-                VoidType = pure (compose s2 s1, t1)
+                VoidType = pure (compose s2 s1, t1, [s_:ss_])
                 _ = lift (unify t1 t2) >>= \s3 -> 
-                    pure (compose s3 $ compose s2 s1, t1)
+                    pure (compose s3 $ compose s2 s1, t1, [s_:ss_])
 
 //the type class inferes the type of an AST element (VarDecl or FunDecl)
 //and adds it to the AST element
@@ -335,7 +351,7 @@ class type a :: a -> Typing (Substitution, a)
 
 instance type VarDecl where
     type (VarDecl p expected k e) = 
-        infer e >>= \(s1, given) ->
+        infer e >>= \(s1, given, e_) ->
         applySubst s1 >>| 
         case expected of
             Nothing = pure zero
@@ -345,7 +361,7 @@ instance type VarDecl where
         let vtype = subst (compose s2 s1) given in
         generalize vtype >>= \t ->
         changeGamma (extend k t) >>| 
-        pure (compose s2 s1, VarDecl p (Just vtype) k e)
+        pure (compose s2 s1, VarDecl p (Just vtype) k e_)
 
 instance type FunDecl where
     type (FunDecl p f args expected vds stmts) = 
@@ -354,7 +370,7 @@ instance type FunDecl where
         mapM introduce args >>= \argTs->
         type vds >>= \(s1, tVds)->
         applySubst s1 >>|
-        infer stmts >>= \(s2, result)->
+        infer stmts >>= \(s2, result, stmts_)->
         applySubst s1 >>|
         let argTs_ = map (subst $ compose s2 s1) argTs in 
         let given = foldr (->>) result argTs_ in 
@@ -366,7 +382,7 @@ instance type FunDecl where
         generalize ftype >>= \t->
         putGamma outerScope >>|
         changeGamma (extend f t) >>| 
-        pure (compose s3 $ compose s2 s1, FunDecl p f args (Just ftype) tVds stmts)
+        pure (compose s3 $ compose s2 s1, FunDecl p f args (Just ftype) tVds stmts_)
 
 instance type [a] | type a where
     type []     = pure (zero, [])
diff --git a/spl.icl b/spl.icl
index 383b84e..c877bd0 100644
--- a/spl.icl
+++ b/spl.icl
@@ -37,12 +37,12 @@ derive gPrint TokenValue
 preamble :: AST -> AST
 preamble (AST fd) = AST (pre ++ fd)
 	where
-		pre = [
-			FunDecl zero "1printstr" ["x"] Nothing [] [
-				IfStmt (FunExpr zero "isEmpty" [VarExpr zero (VarDef "x" [])] [])
-					[]
-					[FunStmt "1printchar" [VarExpr zero (VarDef "x" [FieldHd])] []
-					,FunStmt "1printstr" [VarExpr zero (VarDef "x" [FieldTl])] []]]]
+		pre = [] //[
+			//FunDecl zero "1printstr" ["x"] Nothing [] [
+//				IfStmt (FunExpr zero "isEmpty" [VarExpr zero (VarDef "x" [])] [])
+//					[]
+//					[FunStmt "1printchar" [VarExpr zero (VarDef "x" [FieldHd])] []
+//					,FunStmt "1printstr" [VarExpr zero (VarDef "x" [FieldTl])] []]]]
 
 Start :: *World -> *World
 Start w