merge master
authorpimjager <pim@pimjager.nl>
Thu, 26 May 2016 14:50:44 +0000 (16:50 +0200)
committerpimjager <pim@pimjager.nl>
Thu, 26 May 2016 14:50:44 +0000 (16:50 +0200)
1  2 
examples/tempTest.spl
gen.icl
sem.icl

@@@ -1,18 -1,45 +1,28 @@@
- Let Int a = 4;
 -//Let Int a = 4;//
 -
 -//mapP1(xs) {
 -//    if(isEmpty(xs)) {
 -//        return [];
 -//    } else {
 -//        return (xs.hd + 1) : mapP1(xs.tl);
 -//    }
 -//}
 -//main() {
 -//    [Int] x = [];
 -//    [Int] y = [];
 -//    Int z = a();
 -//    x = mapP1(x);
 -//    y = mapP1(x);
 -//    return a() + 5;
 -//}
 -
+ plus(x,y){
+     return x+y;
+ }
  
- mapP1(xs) {
-     if(isEmpty(xs)) {
+ map(f, xs) {
+     if (isEmpty(xs)) {
          return [];
      } else {
-         return (xs.hd + 1) : mapP1(xs.tl);
+         return f(xs.hd) : map(f, xs.tl);
+     }
+ }
+ foldr(f, acc, xs) {
+     if(isEmpty(xs)) {
+         return acc;
+     } else {
+         return foldr(f, f(xs.hd, acc), xs.tl);
      }
  }
  main() {
-     [Int] x = [];
-     [Int] y = [];
-     Int z = a();
-     var f = \x -> x+1;
-     x = mapP1(x);
-     y = mapP1(x);
-     return a() + 5;
+     var f = plus(1);
+     var z = map(f, 1:2:[]);
+     var x = foldr(plus, 0, 1:2:[]);
+     print(x);
+     return;
++>>>>>>> master
  }
diff --cc gen.icl
+++ b/gen.icl
@@@ -174,130 -174,136 +174,137 @@@ instance g Expr wher
                Just (ADDR t arity) = tell [Instr "ldl" [Lit t] ""] >>| mapM_ g fs >>| pure ()
                Just (LAB l _ fn) = tell 
                        [Instr "ldc" [Lit fn] ""
+                       ,Instr "sth" [] ""
                        ,Instr "ldc" [Lit 0] ""
-                       ,Instr "stmh" [Lit 2] ""]
-     g (LambdaExpr _ _ _) = liftT $ Left $ Error "PANIC: Lambdas should be Unfolded"
-     g (FunExpr _ k es fs) = getAdressbook >>= \ab->case 'Map'.get k ab of
-               //Identifier points to function
-               Just (LAB l arity fn) = if (arity <> (length es))
-                       //Function is not complete
-                       (       tell
-                                       [Instr "ldc" [Lit fn] "Store function number"
-                                       ,Instr "sth" [] ""
-                                       ,Instr "ldc" [Lit $ length es] "Store arity"
-                                       ,Instr "sth" [] ""
-                                       ,Instr "ajs" [Lit -1] ""]
-                               >>| mapM_ g es
-                               >>| if (isEmpty es) (pure ()) (tell 
-                                       [Instr "stmh" [Lit $ length es] "Store arguments"
-                                       ,Instr "ajs" [Lit -1] ""]))
-                       //Function is complete
-                       (       mapM_ g es
-                               >>| jump "bsr" k
-                       >>| tell 
-                                       [Instr "ajs" [Lit $ ~(length es)] "Clean arguments"
-                                       ,Instr "ldr" [Raw "RR"] ""])
-               //Identifier points to variable, thus higher order function
-               Just (ADDR t arity) = if (arity <> (length es))
-                       //Function is still  not complete
-                       ( fresh >>= \finish->fresh >>= \start->tell [
-                               //Store function number
-                                Instr "ldl" [Lit t] "STARTING HIGHER ORDER UPDATE"
-                               ,Instr "ldh" [Lit 0] "get function number"
-                               ,Instr "sth" [] "Store"
-                               //Store function arity
-                               ,Instr "ldl" [Lit t] "get pointer again"
-                               ,Instr "ldh" [Lit 1] "get function arity"
-                               ,Instr "ldc" [Lit $ length es] "add argument number"
-                               ,Instr "add" [] "add"
-                               ,Instr "sth" [] "Store"
-                               ,Instr "ajs" [Lit -1] "Adjust pointer"
-                               //load the arguments
-                               ,Instr "ldl" [Lit t] ""
-                               ,Instr "ldh" [Lit 1] "Load available arguments"
-                               ,Instr "str" [Raw "R5"] "Store available args in register"
-                               ,Instr "ldc" [Lit 0] "Store offset"
-                               ,Instr "str" [Raw "R6"] "Store offset in register"
-                               ,Lab start
-                               ,Instr "ldr" [Raw "R5"] ""
-                               ,Instr "ldc" [Lit 0] ""
-                               ,Instr "eq" [] ""
-                               ,Instr "brt" [L finish] "Done pushing arg, bye"
-                               //Load heapadress
-                               ,Instr "ldl" [Lit t] ""
-                               ,Instr "ldr" [Raw "R6"] ""
-                               ,Instr "add" [] "Corrected heapaddress"
-                               ,Instr "ldh" [Lit 2] "Load argument"
-                               ,Instr "sth" [] "And store it immediatly after"
-                               //Decrease available arguments
-                               ,Instr "ldr" [Raw "R5"] ""
-                               ,Instr "ldc" [Lit 1] ""
-                               ,Instr "sub" [] ""
-                               ,Instr "str" [Raw "R5"] ""
-                               //Increase available arguments
-                               ,Instr "ldr" [Raw "R6"] ""
-                               ,Instr "ldc" [Lit 1] ""
-                               ,Instr "add" [] ""
-                               ,Instr "str" [Raw "R6"] ""
-                               ,Instr "bra" [L start] ""
-                               ,Lab finish
-                               ]
-                         >>| mapM_ g es
-                         >>| tell 
-                                       [Instr "stmh" [Lit $ length es] "Store extra args"
-                                       ,Instr "ajs" [Lit -1] ""]
-                       )
-                       //Function is complete
-                       ( fresh >>= \finish->fresh >>= \start->tell [
-                                Instr "ldl" [Lit t] "STARTING HIGHER ORDER CALL"
-                               ,Instr "ldh" [Lit 1] "Load available arguments"
-                               ,Instr "str" [Raw "R5"] "Store available args in register"
-                               ,Instr "ldc" [Lit 0] "Store offset"
-                               ,Instr "str" [Raw "R6"] "Store offset in register"
-                       
-                               ,Lab start
-                               ,Instr "ldr" [Raw "R5"] ""
-                               ,Instr "ldc" [Lit 0] ""
-                               ,Instr "eq" [] ""
-                               ,Instr "brt" [L finish] "Done pushing arg, bye"
-                               //Load heapadress
-                               ,Instr "ldl" [Lit t] ""
-                               ,Instr "ldr" [Raw "R6"] ""
-                               ,Instr "add" [] "Corrected heapaddress"
-                               ,Instr "ldh" [Lit 2] "Load argument"
-                               //Decrease available arguments
-                               ,Instr "ldr" [Raw "R5"] ""
-                               ,Instr "ldc" [Lit 1] ""
-                               ,Instr "sub" [] ""
-                               ,Instr "str" [Raw "R5"] ""
-                               //Increase available arguments
-                               ,Instr "ldr" [Raw "R6"] ""
-                               ,Instr "ldc" [Lit 1] ""
-                               ,Instr "add" [] ""
-                               ,Instr "str" [Raw "R6"] ""
-                               ,Instr "bra" [L start] ""
-                               ,Lab finish
-                               ]
-                         >>| mapM_ g es
-                         >>| tell
-                               [Instr "ldl" [Lit t] ""
-                               ,Instr "ldh" [Lit 0] "Get function number"
-                               ,Instr "str" [Raw "R5"] ""
-                               ,Instr "bsr" [L "1func"] ""
-                               ,Instr "ldr" [Raw "MP"] ""
-                               ,Instr "ldc" [Lit t] ""
-                               ,Instr "add" [] ""
-                               ,Instr "str" [Raw "SP"] ""
-                               ,Instr "ldr" [Raw "RR"] ""
-                               ]
-                       )
-               Nothing = liftT (Left $ Error "Undefined function!!!")
+                       ,Instr "sth" [] ""
+                       ,Instr "ajs" [Lit -1] ""]
++    g (LambdaExpr _ _ _) = liftT $ Left $ Error "PANIC: Lambdas should be unfolded"
+     g (FunExpr _ k es fs) = funnyStuff k es fs
  
- jump :: String String -> Gen ()
- jump instr k = getAdressbook >>= \ab->case 'Map'.get k ab of
-       Nothing = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as function"])
-       Just (LAB t _ _) = tell [Instr instr [L t] (k +++"()")]
-       Just (ADDR t arity) = abort "NO ADDRESS JUMPING FFS"
+ funnyStuff :: String [Expr] [FieldSelector] -> Gen ()
+ funnyStuff k es fs = getAdressbook >>= \ab->case 'Map'.get k ab of
+       //Identifier points to function
+       Just (LAB l arity fn) = if (arity <> (length es))
+               //Function is not complete
+               (       tell
+                               [Instr "ldc" [Lit fn] "Store function number"
+                               ,Instr "sth" [] ""
+                               ,Instr "ldc" [Lit $ length es] "Store arity"
+                               ,Instr "sth" [] ""
+                               ,Instr "ajs" [Lit -1] ""]
+                       >>| mapM_ g es
+                       >>| if (isEmpty es) (pure ()) (tell 
+                               [Instr "stmh" [Lit $ length es] "Store arguments"
+                               ,Instr "ajs" [Lit -1] ""]))
+               //Function is complete
+               (       mapM_ g es
+                       >>| getAdressbook >>= \ab->(case 'Map'.get k ab of
+                               Nothing = liftT (Left $ Error $ concat ["PANIC: ", k, " not found as function"])
+                               Just (LAB t _ _) = tell [Instr "bsr" [L t] (k +++"()")]
+                               Just (ADDR t arity) = liftT (Left $ Error "NO ADDRESS JUMPING FFS")
+                       )
+               >>| tell 
+                               [Instr "ajs" [Lit $ ~(length es)] "Clean arguments"
+                               ,Instr "ldr" [Raw "RR"] ""])
+       //Identifier points to variable, thus higher order function
+       Just (ADDR t arity) = if (arity <> (length es))
+               //Function is still  not complete
+               ( fresh >>= \finish->fresh >>= \start->tell [
+                       //Store function number
+                        Instr "ldl" [Lit t] "STARTING HIGHER ORDER UPDATE"
+                       ,Instr "ldh" [Lit 0] "get function number"
+                       ,Instr "sth" [] "Store"
+                       //Store function arity
+                       ,Instr "ldl" [Lit t] "get pointer again"
+                       ,Instr "ldh" [Lit 1] "get function arity"
+                       ,Instr "ldc" [Lit $ length es] "add argument number"
+                       ,Instr "add" [] "add"
+                       ,Instr "sth" [] "Store"
+                       ,Instr "ajs" [Lit -1] "Adjust pointer"
+                       //load the arguments
+                       ,Instr "ldl" [Lit t] ""
+                       ,Instr "ldh" [Lit 1] "Load available arguments"
+                       ,Instr "str" [Raw "R5"] "Store available args in register"
+                       ,Instr "ldc" [Lit 0] "Store offset"
+                       ,Instr "str" [Raw "R6"] "Store offset in register"
+                       ,Lab start
+                       ,Instr "ldr" [Raw "R5"] ""
+                       ,Instr "ldc" [Lit 0] ""
+                       ,Instr "eq" [] ""
+                       ,Instr "brt" [L finish] "Done pushing arg, bye"
+                       //Load heapadress
+                       ,Instr "ldl" [Lit t] ""
+                       ,Instr "ldr" [Raw "R6"] ""
+                       ,Instr "add" [] "Corrected heapaddress"
+                       ,Instr "ldh" [Lit 2] "Load argument"
+                       ,Instr "sth" [] "And store it immediatly after"
+                       //Decrease available arguments
+                       ,Instr "ldr" [Raw "R5"] ""
+                       ,Instr "ldc" [Lit 1] ""
+                       ,Instr "sub" [] ""
+                       ,Instr "str" [Raw "R5"] ""
+                       //Increase available arguments
+                       ,Instr "ldr" [Raw "R6"] ""
+                       ,Instr "ldc" [Lit 1] ""
+                       ,Instr "add" [] ""
+                       ,Instr "str" [Raw "R6"] ""
+                       ,Instr "bra" [L start] ""
+                       ,Lab finish
+                       ]
+                 >>| mapM_ g es
+                 >>| tell 
+                               [Instr "stmh" [Lit $ length es] "Store extra args"
+                               ,Instr "ajs" [Lit -1] ""]
+               )
+               //Function is complete
+               ( fresh >>= \finish->fresh >>= \start->tell [
+                        Instr "ldl" [Lit t] "STARTING HIGHER ORDER CALL"
+                       ,Instr "ldh" [Lit 1] "Load available arguments"
+                       ,Instr "str" [Raw "R5"] "Store available args in register"
+                       ,Instr "ldc" [Lit 0] "Store offset"
+                       ,Instr "str" [Raw "R6"] "Store offset in register"
+               
+                       ,Lab start
+                       ,Instr "ldr" [Raw "R5"] ""
+                       ,Instr "ldc" [Lit 0] ""
+                       ,Instr "eq" [] ""
+                       ,Instr "brt" [L finish] "Done pushing arg, bye"
+                       //Load heapadress
+                       ,Instr "ldl" [Lit t] ""
+                       ,Instr "ldr" [Raw "R6"] ""
+                       ,Instr "add" [] "Corrected heapaddress"
+                       ,Instr "ldh" [Lit 2] "Load argument"
+                       //Decrease available arguments
+                       ,Instr "ldr" [Raw "R5"] ""
+                       ,Instr "ldc" [Lit 1] ""
+                       ,Instr "sub" [] ""
+                       ,Instr "str" [Raw "R5"] ""
+                       //Increase available arguments
+                       ,Instr "ldr" [Raw "R6"] ""
+                       ,Instr "ldc" [Lit 1] ""
+                       ,Instr "add" [] ""
+                       ,Instr "str" [Raw "R6"] ""
+                       ,Instr "bra" [L start] ""
+                       ,Lab finish
+                       ]
+                 >>| mapM_ g es
+                 >>| tell
+                       [Instr "ldl" [Lit t] ""
+                       ,Instr "ldh" [Lit 0] "Get function number"
+                       ,Instr "str" [Raw "R5"] ""
+                       ,Instr "bsr" [L "1func"] "HIGHER ORDER END"
+                       ,Instr "ldl" [Lit t] ""
+                       ,Instr "ldh" [Lit 1] ""
+                       ,Instr "neg" [] ""
+                       ,Instr "ldr" [Raw "SP"] ""
+                       ,Instr "add" [] ""
+                       ,Instr "ldc" [Lit $ length es + 1] ""
+                       ,Instr "sub" [] ""
+                       ,Instr "str" [Raw "SP"] ""
+                       ,Instr "ldr" [Raw "RR"] ""
+                       ]
+               )
+       Nothing = liftT (Left $ Error "Undefined function!!!")
  
  instance g Stmt where
      g (IfStmt cond th el) = 
diff --cc sem.icl
+++ b/sem.icl
@@@ -5,6 -5,6 +5,7 @@@ import qualified Data.Map as Ma
  from Data.Func import $
  from StdFunc import o, flip, const, id
  
++import Control.Applicative
  import Control.Monad
  import Control.Monad.Trans
  import Control.Monad.State
@@@ -88,19 -88,6 +89,21 @@@ wher
                                _ = Left $ SanityError p "main has to return Void")
                isNiceMain _ = pure ()
  
-                         unfoldLambda fds2 >>= \fds2->
 +unfoldLambda :: [FunDecl] -> Typing [FunDecl]
 +unfoldLambda [fd:fds] = unf_ fd >>= \fds1-> 
-         mapM_ unfv_ vds >>= \fds1->
-         mapM_ unfs_ stmts >>= \fds2->
-         pure [fd:fds] ++ fds2
-     unfv_ :: Typing [FunDecl]
-     unfv_ (VarDecl _ _ _ e) = abort ""
-     unfs_ _ = abort ""
++                        unfoldLambda fds >>= \fds2->
 +                        pure $ fds1 ++ fds2
 +where
++    unf_ :: FunDecl -> Typing [FunDecl]
 +    unf_ fd=:(FunDecl _ _ _ _ vds stmts) = 
++        flatten <$> mapM unfv_ vds >>= \fds1->
++        flatten <$> mapM unfs_ stmts >>= \fds2->
++        pure $ [fd:fds1] ++ fds2
++    unfv_ :: VarDecl -> Typing [FunDecl]
++    unfv_ (VarDecl _ _ _ e) = pure []
++    unfs_ :: Stmt -> Typing [FunDecl]
++    unfs_ _ = pure []
 +
  class Typeable a where
      ftv :: a -> [TVar]
      subst :: Substitution a -> a