compiler works on abs and fibonacci

examples/gfcc/Imper.gf

@@ -24,13 +24,15 @@ abstract Imper = PredefAbs ** {
     RecCons : (A : Typ) -> (AS : ListTyp) -> 
                   (Var A -> Rec AS) -> Program -> Rec (ConsTyp A AS) ;
 
-    Decl   : (A : Typ) -> (Var A -> Stm) -> Stm ;
+    Decl    : (A : Typ) -> (Var A -> Stm) -> Stm ;
-    Assign : (A : Typ) -> Var A -> Exp A -> Stm -> Stm ;
+    Assign  : (A : Typ) -> Var A -> Exp A -> Stm -> Stm ;
-    Return : (A : Typ) -> Exp A -> Stm ;
+    While   : Exp TInt -> Stm -> Stm -> Stm ;
-    While  : Exp TInt -> Stm -> Stm -> Stm ;
+    IfElse  : Exp TInt -> Stm -> Stm -> Stm -> Stm ;
-    IfElse : Exp TInt -> Stm -> Stm -> Stm -> Stm ;
+    Block   : Stm -> Stm -> Stm ;
-    Block  : Stm -> Stm -> Stm ;
+    Printf  : (A : Typ) -> Exp A -> Stm -> Stm ;
-    End    : Stm ;
+    Return  : (A : Typ) -> Exp A -> Stm ;
+    Returnv : Stm ;
+    End     : Stm ;
 
     EVar   : (A : Typ) -> Var A -> Exp A ;
     EInt   : Int -> Exp (TNum TInt) ;

examples/gfcc/ImperC.gf

@@ -27,10 +27,12 @@ concrete ImperC of Imper = open ResImper in {
 
     Decl  typ cont = continues (typ.s ++ cont.$0) cont ;
     Assign _ x exp = continues (x.s ++ "=" ++ exp.s) ;
-    Return _ exp   = statement ("return" ++ exp.s) ;
     While exp loop = continue  ("while" ++ paren exp.s ++ loop.s) ;
     IfElse exp t f = continue  ("if" ++ paren exp.s ++ t.s ++ "else" ++ f.s) ;
     Block stm      = continue  ("{" ++ stm.s ++ "}") ;
+    Printf t e     = continues ("printf" ++ paren (t.s ++ "," ++ e.s)) ;
+    Return _ exp   = statement ("return" ++ exp.s) ;
+    Returnv        = statement "return" ;
     End            = ss [] ;
  
     EVar  _ x  = constant x.s ;

examples/gfcc/ImperJVM.gf

@@ -36,13 +36,7 @@ flags lexer=codevars ; unlexer=code ; startcat=Stm ;
     Decl  typ cont = instrb typ.s (
       ["alloc"] ++ typ.s ++ cont.$0
       ) cont ;
-    Assign t x exp = instrc (
+    Assign t x exp = instrc (exp.s ++ t.s ++ "_store" ++ x.s) ;
-      exp.s ++ 
-      t.s ++ "_store" ++ x.s
-      ) ;
-    Return t exp   = instr (
-      exp.s ++ 
-      t.s ++ "_return") ;
     While exp loop = 
       let 
         test = "TEST_" ++ loop.s2 ; 
@@ -69,14 +63,17 @@ flags lexer=codevars ; unlexer=code ; startcat=Stm ;
         "label" ++ true
         ) ;
     Block stm      = instrc stm.s ;
+    Printf t e     = instrc (e.s ++ "invokestatic" ++ t.s ++ "runtime/printf" ++ paren (t.s) ++ "v") ;
+    Return t exp   = instr (exp.s ++ t.s ++ "_return") ;
+    Returnv        = instr "return" ;
     End            = ss [] ** {s2,s3 = []} ;
 
     EVar  t x  = instr (t.s ++ "_load" ++ x.s) ;
     EInt    n  = instr ("ldc" ++ n.s) ;
     EFloat a b = instr ("ldc" ++ a.s ++ "." ++ b.s) ;
-    EAdd       = binopt "add" ;
+    EAdd       = binopt "_add" ;
-    ESub       = binopt "sub" ;
+    ESub       = binopt "_sub" ;
-    EMul       = binopt "mul" ;
+    EMul       = binopt "_mul" ;
     ELt t      = binop ("invokestatic" ++ t.s ++ "runtime/lt" ++ paren (t.s ++ t.s) ++ "i") ;
     EApp args val f exps = instr (
       exps.s ++

examples/gfcc/ResImper.gf

@@ -72,6 +72,6 @@ resource ResImper = open Predef in {
       ss (s ++ ";" ++ i.s) ** {s2 = v ++ i.s2 ; s3 = i.s3} ;
     binop  : Str -> SS -> SS -> SS = \op, x, y ->
       ss (x.s ++ y.s ++ op ++ ";") ;
-    binopt : Str -> SS -> SS -> SS -> SS = \op, x, y, t ->
+    binopt : Str -> SS -> SS -> SS -> SS = \op, t ->
-      ss (x.s ++ y.s ++ t.s ++ op ++ ";") ;
+      binop (t.s ++ op) ;
 }

examples/gfcc/compiler/CleanJVM.hs

@@ -3,6 +3,8 @@ module Main where
 import Char
 import System
 
+--- now works for programs with exactly 2 functions, main last
+
 main :: IO ()
 main = do
   jvm:src:_ <- getArgs
@@ -12,30 +14,38 @@ main = do
   writeFile  obj $ boilerplate cls
   appendFile obj $ mkJVM cls s
   putStrLn $ "wrote file " ++ obj
+  system $ "jasmin " ++ obj
+  return () 
 
 mkJVM :: String -> String -> String
 mkJVM cls = unlines . map trans . lines where
   trans s = case words s of
-    ".method":p:s:f:ns   -> unwords [".method",p,s, unindex f ++ typesig ns]
+    ".method":p:s:f:ns
-    ".limit":"locals":ns -> ".limit locals " ++ show (length ns - 1)
+        | take 5 f == "main_" -> ".method public static main([Ljava/lang/String;)V"   
-    "invokestatic":t:"runtime/lt":ns -> ".invokestatic " ++ "runtime/" ++ t ++ "lt" ++ typesig ns 
+        | otherwise  -> unwords [".method",p,s, unindex f ++ typesig ns]
+    ".limit":"locals":ns -> ".limit locals " ++ show (length ns)
+    "invokestatic":t:f:ns | take 8 f == "runtime/" -> 
+        "invokestatic " ++ "runtime/" ++ t ++ drop 8 f ++ typesig ns 
     "invokestatic":f:ns  -> "invokestatic " ++ cls ++ "/" ++ unindex f ++ typesig ns 
     "alloc":ns           -> "; " ++ s
+    t:('_':instr):[]     -> t ++ instr
     t:('_':instr):x:_    -> t ++ instr ++ " " ++ address x
-    "goto":ns            -> "goto "   ++ label ns
+    "goto":ns            -> "goto " ++ label ns
-    "ifeq":ns            -> "ifzero " ++ label ns
+    "ifeq":ns            -> "ifeq " ++ label ns
-    "label":ns           -> label ns
+    "label":ns           -> label ns ++ ":"
     ";":[] -> ""
     _ -> s
    where
      unindex = reverse . drop 1 . dropWhile (/= '_') . reverse
      typesig = init . map toUpper . concat
-     address = reverse . takeWhile (/= '_') . reverse
+     address x = case (filter isDigit . reverse . takeWhile (/= '_') . reverse) x of
+       s@(_:_) -> show $ read s - (1 :: Int)
+       s -> s
      label   = init . concat
 
 boilerplate :: String -> String
 boilerplate cls = unlines [
-  ".class public " ++ cls ++ ".j",
+  ".class public " ++ cls,
   ".super java/lang/Object",
   ".method public <init>()V",
   "aload_0",

examples/gfcc/compiler/abs.c

@@ -1,12 +1,20 @@
 int abs (int x){
+  int y ;
+  {
   if (x < 0){
-    return 0 - x ;
+    y = 0 - x ;
     }
-  else return x ;
+  else {
+    y = x ;
+    }
+  }
+  return y ;
   } ;
 int main () {
   int i ;
   i = abs (16);
+  printf (int,i) ;
+  return ;
   } ;
 
 

examples/gfcc/compiler/fibonacci.c

@@ -0,0 +1,18 @@
+int mx () {
+  return 5000000 ;
+} ;
+
+int main () {
+  int lo ; int hi ;
+  lo = 1 ;
+  hi = lo ;
+  printf(int,lo) ;
+  {
+    while (hi < mx()) {
+      printf(int,hi) ;
+      hi = lo + hi ;
+      lo = hi - lo ;
+      }
+  }
+  return ;
+} ;

examples/gfcc/compiler/runtime.j

@@ -19,7 +19,37 @@
   Label0:
     iconst_0
     ireturn
-  Label1:
 .end method
 
-; TODO: flt missing
+.method public static flt(FF)I
+.limit locals 2
+.limit stack 2
+    fload_0
+    fload_1
+    fcmpl
+    ifge Label0
+    iconst_1
+    ireturn
+  Label0:
+    iconst_0
+    ireturn
+.end method
+
+.method public static iprintf(I)V
+.limit locals 1
+.limit stack 1000
+  getstatic java/lang/System/out Ljava/io/PrintStream;
+  iload_0
+  invokevirtual java/io/PrintStream/println(I)V
+  return
+.end method
+
+.method public static fprintf(F)V
+.limit locals 1
+.limit stack 1000
+  getstatic java/lang/System/out Ljava/io/PrintStream;
+  fload_0
+  invokevirtual java/io/PrintStream/println(F)V
+  return
+.end method
+