Changeset 5644

Timestamp:

07/17/05 19:41:27 (3 years ago)

Author:

iblech

svk:copy_cache_prev:

7648

Message:

PIL -> JavaScript? compiler.
* Pugs.Compile: Modified the declaration of PApp to accept an invocant.
* Pugs.CodeGen?.PIR: Minor changes because of change #1, pugs -BPIR still passes

the sanity tests.

* New directory perl5/PIL2JS, containing various modules, a README, and

pil2js.pl:
$ pugs -CPIL -Ilib6 -MPrelude::JS -we 'say 2 + 3' | \

./pil2js.pl -html > /tmp/t.html

* t/01-sanity mostly pass! (see

http://m19s28.vlinux.de/iblech/stuff/not_perm/pil2js-demo/)

* t/01-sanity/03-equal.t doesn't pass because of a bug in Pugs.Compile

("3 4" is compiled to "&infix:<>(3, 4)" instead of "&infix:<>(3, {4})"
or something similar.

* See perl5/PIL2JS/README for a list of things which already work.

Files:

• perl5/PIL2JS (added)
• perl5/PIL2JS/README (added)
• perl5/PIL2JS/lib (added)
• perl5/PIL2JS/lib/PIL (added)
• perl5/PIL2JS/lib/PIL/Nodes.pm (added)
• perl5/PIL2JS/lib/PIL/Parser.pm (added)
• perl5/PIL2JS/lib6 (added)
• perl5/PIL2JS/lib6/Prelude (added)
• perl5/PIL2JS/lib6/Prelude/JS.pm (added)
• perl5/PIL2JS/pil2js.pl (added)
• src/Pugs/CodeGen/PIR.hs (modified) (1 diff)
• src/Pugs/Compile.hs (modified) (10 diffs)
• src/Pugs/Parser.hs (modified) (1 diff)

src/Pugs/CodeGen/PIR.hs

@@ -108 +108 @@
         tell [thisC]
         trans rest
-    trans (PApp _ exp@(PCode _ _ _) []) = do
+    trans (PApp _ exp@(PCode _ _ _) Nothing []) = do
         blockC  <- trans exp
         tellIns $ [reg tempPMC] <-& blockC $ []
         return tempPMC
-    trans (PApp (TCxtLValue _) (PExp (PVar "&postcircumfix:[]")) [PExp lhs, rhs]) = do
+    trans (PApp (TCxtLValue _) (PExp (PVar "&postcircumfix:[]")) Nothing [PExp lhs, rhs]) = do
         lhsC    <- trans lhs
         rhsC    <- trans rhs
         return $ lhsC `KEYED` rhsC
-    trans (PApp _ fun args) = do
+    trans (PApp ctx fun (Just inv) args) =
+        trans (PApp ctx fun Nothing (inv:args))  -- XXX wrong
+    trans (PApp _ fun Nothing args) = do
         funC    <- trans fun {- case fun of
             PExp (PVar name) -> return $ lit name

src/Pugs/Compile.hs

@@ -47 +47 @@
     PStmts      :: !(PIL Stmt) -> !(PIL [Stmt]) -> PIL [Stmt]
 
-    PApp        :: !TCxt -> !(PIL Expression) -> ![PIL Expression] -> PIL LValue
+    PApp        :: !TCxt -> !(PIL Expression) -> !(Maybe (PIL Expression)) -> ![PIL Expression] -> PIL LValue
     PAssign     :: ![PIL LValue] -> !(PIL Expression) -> PIL LValue
     PBind       :: ![PIL LValue] -> !(PIL Expression) -> PIL LValue
@@ -90 +90 @@
     show PNoop = "PNoop"
     show (PPos x y z) = "(PPos " ++ show x ++ " " ++ show y ++ " " ++ show z ++ ")"
-    show (PApp x y z) = "(PApp " ++ show x ++ " " ++ show y ++ " " ++ show z ++ ")"
+    show (PApp x y i z) = "(PApp " ++ show x ++ " " ++ show y ++ " " ++ show i ++ " " ++ show z ++ ")"
     show (PExp x) = "(PExp " ++ show x ++ ")"
     show (PStmt x) = "(PStmt " ++ show x ++ ")"
@@ -176 +176 @@
 instance Compile (SubName, [PIL Decl]) [PIL Decl] where
     compile (name, decls) = do
-        let bodyC = [ PStmts . PStmt . PExp $ PApp tcVoid (PExp (PVar sub)) []
+        let bodyC = [ PStmts . PStmt . PExp $ PApp tcVoid (PExp (PVar sub)) Nothing []
                     | PSub sub _ _ _ <- decls
                     ]
@@ -223 +223 @@
         return $ PStmts (tailCall thisC) PNil
         where
-        tailCall (PStmt (PExp (PApp cxt fun args)))
-            = PStmt $ PExp $ PApp (TTailCall cxt) fun args
+        tailCall (PStmt (PExp (PApp cxt fun inv args)))
+            = PStmt $ PExp $ PApp (TTailCall cxt) fun inv args
         tailCall (PPos pos exp x) = PPos pos exp (tailCall x)
         tailCall x = x
@@ -265 +265 @@
         postC   <- compile post
         funC    <- compile (Var "&statement_control:loop")
-        return . PStmt . PExp $ PApp TCxtVoid funC
+        return . PStmt . PExp $ PApp TCxtVoid funC Nothing
             [preC, pBlock condC, pBlock bodyC, pBlock postC]
     compile exp@(Syn "unless" _) = fmap (PStmt . PExp) $ compConditional exp
@@ -276 +276 @@
         bodyC   <- compile body
         funC    <- compile (Var "&statement_control:for")
-        return . PStmt . PExp $ PApp TCxtVoid funC [expC, bodyC]
+        return . PStmt . PExp $ PApp TCxtVoid funC Nothing [expC, bodyC]
     compile (Syn "given" _) = compile (Var "$_") -- XXX
     compile (Syn "when" _) = compile (Var "$_") -- XXX
@@ -323 +323 @@
         funC    <- compile inv
         argsC   <- enter cxtItemAny $ compile args
-        return $ PApp (TTailCall cxt) funC argsC
-    compile (App fun (Just inv) args) = do
-        compile (App fun Nothing (inv:args)) -- XXX WRONG
-    compile (App fun Nothing args) = do
+        return $ PApp (TTailCall cxt) funC Nothing argsC
+    compile (App fun inv args) = do
         cxt     <- askTCxt
         funC    <- compile fun
+        invC    <- maybeM (return inv) compile
         argsC   <- enter cxtItemAny $ compile args
-        return $ PApp cxt funC argsC
+        return $ PApp cxt funC invC argsC
     compile exp@(Syn "if" _) = compConditional exp
     compile (Syn "{}" (x:xs)) = compile $ App (Var "&postcircumfix:{}") (Just x) xs
@@ -361 +360 @@
     bodyC   <- enter CxtVoid $ compile body
     funC    <- compile (Var $ "&statement_control:" ++ name)
-    return . PStmt . PExp $ PApp cxt funC [pBlock condC, pBlock bodyC]
+    return . PStmt . PExp $ PApp cxt funC Nothing [pBlock condC, pBlock bodyC]
 compLoop exp = compError exp
 
@@ -372 +371 @@
     funC    <- compile $ Var ("&statement_control:" ++ name)
     cxt     <- askTCxt
-    return $ PApp cxt funC [condC, PThunk trueC, PThunk falseC]
+    return $ PApp cxt funC Nothing [condC, PThunk trueC, PThunk falseC]
 compConditional exp = compError exp
 
@@ -386 +385 @@
         cxt     <- askTCxt
         bodyC   <- compile body
-        return $ PExp $ PApp cxt (pBlock bodyC) []
+        return $ PExp $ PApp cxt (pBlock bodyC) Nothing []
     compile (Syn "sub" [Val (VCode sub)]) = do
         bodyC   <- enter sub $ compile $ case subBody sub of

src/Pugs/Parser.hs

@@ -626 +626 @@
 ruleDoBlock = rule "do block" $ try $ do
     symbol "do"
-    choice 
+    choice
         [ ruleBlockDeclaration
         , ruleDeclaration