From a5c4e896f3f80da310ebd2a562672a47b62d323a Mon Sep 17 00:00:00 2001 From: pimjager Date: Fri, 20 May 2016 17:37:19 +0200 Subject: [PATCH] print specialised --- examples/codeGen.spl | 10 +++- sem.icl | 116 ++++++++++++++++++++++++------------------- spl.icl | 12 ++--- 3 files changed, 81 insertions(+), 57 deletions(-) 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 -- 2.20.1