making parsing ImperC work

examples/gfcc/Imper.gf

@@ -2,6 +2,7 @@ abstract Imper = PredefAbs ** {
 
   cat
     Program ;
+    Rec ListTyp ;
     Typ ;
     NumTyp ;
     ListTyp ;
@@ -15,12 +16,13 @@ abstract Imper = PredefAbs ** {
   fun
     Empty : Program ;
     Funct : (AS : ListTyp) -> (V : Typ) -> 
-              Body AS -> (Fun AS V -> Program) -> Program ;
+              (Fun AS V -> Rec AS) -> Program ;
+    FunctNil : (V : Typ) -> 
+                 Stm -> (Fun NilTyp V -> Program) -> Program ;
 
-    BodyNil  : Stm -> Body NilTyp ;
+    RecOne  : (A : Typ) -> (Var A -> Stm) -> Program -> Rec (ConsTyp A NilTyp) ;
-    BodyOne  : (A : Typ) -> (Var A -> Stm) -> Body (ConsTyp A NilTyp) ;
+    RecCons : (A : Typ) -> (AS : ListTyp) -> 
-    BodyCons : (A : Typ) -> (AS : ListTyp) -> 
+                  (Var A -> Rec AS) -> Program -> Rec (ConsTyp A AS) ;
-                  (Var A -> Body AS) -> Body (ConsTyp A AS) ;
 
     Decl   : (A : Typ) -> (Var A -> Stm) -> Stm ;
     Assign : (A : Typ) -> Var A -> Exp A -> Stm -> Stm ;

examples/gfcc/ImperC.gf

@@ -4,21 +4,25 @@ concrete ImperC of Imper = open ResImper in {
 
   lincat
     Exp = PrecExp ;
-    Body = {s,s2 : Str} ;
+    Rec = {s,s2,s3 : Str} ;
 
   lin
     Empty = ss [] ;
-    Funct args val body cont = ss (
+    FunctNil val stm cont = ss (
-      val.s ++ cont.$0 ++ paren body.s2 ++ "{" ++ 
+      val.s ++ cont.$0 ++ paren [] ++ "{" ++ 
-      body.s ++ "}" ++ ";" ++ cont.s) ;
+      stm.s ++ "}" ++ ";" ++ cont.s) ;
+    Funct args val rec = ss (
+      val.s ++ rec.$0 ++ paren rec.s2 ++ "{" ++ 
+      rec.s ++ "}" ++ ";" ++ rec.s3) ;
 
-    BodyNil stm = stm ** {s2 = []} ;
+    RecOne typ stm prg = stm ** {
-    BodyOne typ stm = stm ** {
+      s2 = typ.s ++ stm.$0 ;
-      s2 = typ.s ++ stm.$0
+      s3 = prg.s
       } ;
-    BodyCons typ _ body = {
+    RecCons typ _ body prg = {
       s  = body.s ; 
       s2 = typ.s ++ body.$0 ++ "," ++ body.s2 ;
+      s3 = prg.s
       } ;
 
     Decl  typ cont = continues (typ.s ++ cont.$0) cont ;

examples/gfcc/ImperJVM.gf

@@ -1,24 +1,37 @@
+--# -path=.:../prelude
 concrete ImperJVM of Imper = open ResImper in {
 
 flags lexer=codevars ; unlexer=code ; startcat=Stm ;
 
   lincat
-    Body  = {s,s2 : Str} ; -- code, storage for locals
+    Rec = {s,s2,s3 : Str} ; -- code, storage for locals, continuation
     Stm = Instr ;
 
   lin
     Empty = ss [] ;
-    Funct args val body rest = ss (
+    FunctNil val stm cont = ss (
-      ".method" ++ rest.$0 ++ paren args.s ++ val.s ++ ";" ++
+      ".method" ++ cont.$0 ++ paren [] ++ val.s ++ ";" ++
-      ".limit" ++ "locals" ++ body.s2 ++ ";" ++
+      ".limit" ++ "locals" ++ stm.s2 ++ ";" ++
       ".limit" ++ "stack" ++ "1000" ++ ";" ++
-      body.s ++
+      stm.s ++
       ".end" ++ "method" ++ ";" ++
-      rest.s 
+      cont.s 
       ) ;
-    BodyNil stm = stm ;
+    Funct args val rec = ss (
-    BodyCons a as body = instrb a.s (
+      ".method" ++ rec.$0 ++ paren args.s ++ val.s ++ ";" ++
-      "alloc" ++ a.s ++ body.$0 ++ body.s2) (body ** {s3 = []});
+      ".limit" ++ "locals" ++ rec.s2 ++ ";" ++
+      ".limit" ++ "stack" ++ "1000" ++ ";" ++
+      rec.s ++
+      ".end" ++ "method" ++ ";" ++
+      rec.s3 
+      ) ;
+
+    RecOne typ stm prg = instrb typ.s (
+      "alloc" ++ typ.s ++ stm.$0 ++ stm.s2) {s = stm.s ; s2 = stm.s2 ; s3 = prg.s};
+
+    RecCons typ _ body prg = instrb typ.s (
+      "alloc" ++ typ.s ++ body.$0 ++ body.s2) 
+         {s = body.s ; s2 = body.s2 ; s3 = prg.s};
 
     Decl  typ cont = instrb typ.s (
       "alloc" ++ typ.s ++ cont.$0
@@ -61,19 +74,16 @@ flags lexer=codevars ; unlexer=code ; startcat=Stm ;
     EVar  t x  = instr (t.s ++ "_load" ++ x.s) ;
     EInt    n  = instr ("ipush" ++ n.s) ;
     EFloat a b = instr ("fpush" ++ a.s ++ "." ++ b.s) ;
-    EAddI      = binop "iadd" ;
+    EAdd       = binopt "add" ;
-    EAddF      = binop "fadd" ;
+    ESub       = binopt "sub" ;
-    ESubI      = binop "isub" ;
+    EMul       = binopt "mul" ;
-    ESubF      = binop "fsub" ;
+    ELt t      = binop ("invoke" ++ t.s ++ "lt" ++ paren (t.s ++ t.s) ++ "i") ;
-    EMulI      = binop "imul" ;
-    EMulF      = binop "fmul" ;
-    ELtI       = binop ("call" ++ "ilt") ;
-    ELtF       = binop ("call" ++ "flt") ;
     EApp args val f exps = instr (
       exps.s ++
       "invoke" ++ f.s ++ paren args.s ++ val.s
       ) ;
 
+    TNum t = t ;
     TInt   = ss "i" ;
     TFloat = ss "f" ;
 
@@ -81,5 +91,6 @@ flags lexer=codevars ; unlexer=code ; startcat=Stm ;
     ConsTyp = cc2 ;
 
     NilExp = ss [] ;
+    OneExp _ e = e ;
     ConsExp _ _ = cc2 ;
 }

examples/gfcc/ResImper.gf

@@ -67,4 +67,6 @@ resource ResImper = {
       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 ->
+      ss (x.s ++ y.s ++ t.s ++ op ++ ";") ;
 }

src/GF/Grammar/PrGrammar.hs

@@ -168,6 +168,7 @@ instance Print Val where
   prt (VClos env e) = case e of
     Meta _ -> prt_ e ++ prEnv env
     _      -> prt_ e ---- ++ prEnv env ---- for debugging
+  prt VType = "Type"
  
 prv1 v = case v of
   VApp _ _  -> prParenth $ prt v

src/GF/Source/LexGF.hs

@@ -59,7 +59,7 @@ prToken t = case t of
   PT _ (TD s) -> s
   PT _ (TC s) -> s
   PT _ (T_LString s) -> s
-
+  _ -> show t
 
 eitherResIdent :: (String -> Tok) -> String -> Tok
 eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where